\ Little Forth Answers Ham 12:00 11/01/92 \ Answers generally appear in same sequence as exercises in \ the book, but sometimes order is permuted to allow screens \ to be loaded in sequence. \ Some words defined in exercises are used in later exercises. \ Chapter number appears in square brackets. \ Copyright (c) 1991 by Michael Ham. All rights reserved. \ Laboratory Microsystems, Inc. \ 12555 West Jefferson Boulevard Suite 202 \ Los Angeles, CA 90066 \ Telephone 213/306-7412 (BBS 213/306-3530) \ Binary representation [2] Ham 12:00 11/01/92 \ Entering the sequence BINARY 11111111 DECIMAL . \ shows that the binary number 11111111 is the same as the \ decimal number 255. \ NIP TUCK RC & others [3] Ham 12:00 11/01/92 \ Definitions of DROP SWAP ROT OVER DUP -- see end of chapter : RC ( row col - ) SWAP GOTOXY ; \ first version : NIP ( n1 n2 - n2 ) SWAP DROP ; : TUCK ( n1 n2 - n1 n2 n1 ) SWAP OVER ; : Y-CLIP ( n - n' ) 0 MAX 24 MIN ; \ clip to range 0-24 : X-CLIP ( n - n' ) 0 MAX 79 MIN ; \ clip to range 0-79 : RC ( row col - ) X-CLIP SWAP Y-CLIP GOTOXY ; \ 2nd version \ After LOADing screen, FORGET the 2nd RC to execute the 1st RC \ Experiments with 2words [3] Ham 12:00 11/01/92 \ 2DROP & DROP DROP \ 2OVER & OVER OVER \ 2DUP & DUP DUP \ 2SWAP & SWAP SWAP \ Experiment (using .S) to determine whether the above are \ equivalent. Don't forget that you must have 4 numbers on the \ stack for 2OVER and 2SWAP. \ It is important to develop the habit of finding your own \ answers by experimentation; not only does it do wonders \ for your sense of self-reliance, it keeps you from being \ misled by inaccurate or out-of-date documentation and manuals. \ TITLE and FIELD [5] Ham 12:00 11/01/92 \ Did you create the file PLAY.SCR and enter the definitions? : TITLE CLS 34 4 GOTOXY REVERSE ." PROGRAM TITLE" -REVERSE 33 6 GOTOXY INTENSITY ." By <your name>" -INTENSITY 22 12 GOTOXY ." Copyright (c) <year> <your name>" 30 14 GOTOXY ." All rights reserved." 35 20 GOTOXY BLINK ." Loading..." -BLINK ; : FIELD ( n - ) DUP BACKGROUND BORDER ; \ set screen color \ TABLE-LINE and TABLE-INSIDES [6] Ham 12:00 11/01/92 \ Computations: check these by executing the phrases. \ First definitions for multiplication table : TABLE-LINE ( n - ) \ accept line number, display product 13 0 DO DUP I * . LOOP DROP ; : TABLE-INSIDES ( - ) \ display interior of multiplication table 13 0 DO I ( I is the line number ) TABLE-LINE CR LOOP ; \ Note how numbers do not line up. See improved definition \ on next screen. \ Better TABLE-LINE and TABLE-INSIDES [6] Ham 12:00 11/01/92 \ improved definition to line up numbers : TABLE-LINE ( n - ) \ accept line number, display product 13 0 DO DUP I * 5 .R LOOP DROP ; : TABLE-INSIDES ( - ) \ display interior of multiplication table 13 0 DO I ( I is the line number ) TABLE-LINE CR LOOP ; \ : SPACE ." " ; \ Example of a definition of SPACE \ : SPACES 0 ?DO SPACE LOOP ; \ Example of defn of SPACES \ TABLE-LINE and TABLE-INSIDES w/ titles [6] Ham 12:00 11/01/92 \ improved definition with titles (top and side) : *TABLE-LINE ( n - ) \ accept line number, display product 13 0 DO DUP I * 5 .R LOOP DROP ; : *TITLE-LINE ." *" 2 SPACES 1 *TABLE-LINE ; : *TABLE ( - ) \ display multiplication table CR CR *TITLE-LINE CR CR 13 0 DO I \ I is the line number DUP 2 .R 2 SPACES \ line title (at side) *TABLE-LINE CR LOOP ; \ Addition table version [6] Ham 12:00 11/01/92 \ Variation: ADDITION table : +TABLE-LINE ( n - ) \ accept line number, display sum 13 0 DO DUP I + 5 .R LOOP DROP ; : +TITLE-LINE ." +" 2 SPACES 0 +TABLE-LINE ; \ The above uses 0 in place of 1. 0 is the identity for \ addition as 1 is for multiplication: n + 0 = n * 1 = n : +TABLE ( - ) \ display addition table CR CR +TITLE-LINE CR CR 13 0 DO I ( I is the line number ) DUP 2 .R 2 SPACES +TABLE-LINE CR LOOP ; \ Color names and timing of color words [6] Ham 12:00 11/01/92 \ Examples 0 CONSTANT BLACK 1 CONSTANT GREEN 2 CONSTANT BLUE 3 CONSTANT RED 7 CONSTANT WHITE : BLUE1 ( - 2 ) 2 ; \ less efficient definition 2 CONSTANT BLUE2 \ more efficient definition : TEST1 !TIMER 60000 0 DO BLUE1 DROP LOOP .TIMER ; : TEST2 !TIMER 60000 0 DO BLUE2 DROP LOOP .TIMER ; CR .( TEST1 = ) TEST1 .( sec ) CR .( TEST2 = ) TEST2 .( sec ) \ Display of colors, two versions [6] Ham 12:00 11/01/92 : ROW ( n - ) 0 MAX 15 MIN ." BACKGROUND " DUP 2 .R 2 SPACES BACKGROUND 15 0 DO I DUP FOREGROUND SPACE . LOOP B/W ; : DISPLAY ( - ) CLS 15 0 DO I ROW CR LOOP ; \ The phrase 0 MAX 15 MIN in ROW is not necessary since ROW \ gets its input (in DISPLAY) from an index that can take only \ the values 0 through 15. Remove the phrase from ROW. : ROW2 ( n - ) ." FOREGROUND " DUP 2 .R 2 SPACES FOREGROUND 15 0 DO I DUP BACKGROUND SPACE . LOOP B/W ; : DISPLAY2 ( - ) CLS 15 0 DO I ROW2 CR LOOP ; \ Various stack-display words [6] Ham 12:00 11/01/92 : DEEP 9 0 DO DEPTH LOOP ; \ Enter DEEP DEPTH . <return> to find depth of stack after DEEP \ In definitions below, ?DO is used since the depth can be 0. : .S1 DEPTH 0 ?DO . LOOP ; \ .S1 empties the stack : .S2 DEPTH 0 ?DO I PICK . LOOP ; \ display stack from top : .S3 DEPTH 0 ?DO DEPTH 1 - I - PICK . LOOP ; : .S4 DEPTH 0 ?DO CR I PICK 5 .R LOOP ; \ Speed tests of equivalent phrases [6] Ham 12:00 11/01/92 : TEST1 !TIMER 5 20000 0 DO 0 PICK DROP LOOP .TIMER DROP ; : TEST2 !TIMER 5 20000 0 DO DUP DROP LOOP .TIMER DROP ; : TEST3 !TIMER 4 5 20000 0 DO 1 PICK DROP LOOP .TIMER 2DROP ; : TEST4 !TIMER 4 5 20000 0 DO OVER DROP LOOP .TIMER 2DROP ; : TEST5 !TIMER 4 5 20000 0 DO 1 ROLL LOOP .TIMER 2DROP ; : TEST6 !TIMER 4 5 20000 0 DO SWAP LOOP .TIMER 2DROP ; : TEST7 !TIMER 3 4 5 20000 0 DO 2 ROLL LOOP .TIMER 2DROP DROP ; : TEST8 !TIMER 3 4 5 20000 0 DO ROT LOOP .TIMER 2DROP DROP ; \ The above tests show the time in seconds for equivalent pairs \ of instructions. \ INCR and DECR (both very useful) [7] Ham 12:00 11/01/92 : INCR ( adr - ) 1 SWAP +! ; \ increment variable by 1 : DECR ( adr - ) -1 SWAP +! ; \ decrement variable by 1 \ A definition of +!: \ : +! ( n adr - ) TUCK @ + SWAP ! ; \ Example: VARIABLE SAM 49 SAM ! CR SAM INCR SAM @ . CR SAM DECR SAM @ . CR \ Musical words: QTR, HALF, HZ, et al. [7] Ham 12:00 11/01/92 VARIABLE LENGTH \ time for duration : QTR 50 LENGTH ! ; \ set duration for quarter notes : HALF 100 LENGTH ! ; \ and half notes : DURATION ( - n ) LENGTH @ ; : WAIT ( n - ) 32000 SWAP BEEP ; \ n = length of wait : Hz ( freq - ) DURATION BEEP 10 WAIT ; : C 264 Hz ; : D 297 Hz ; : E 330 Hz ; : F 352 Hz ; : G 396 Hz ; : A 440 Hz ; : B 495 Hz ; : C' 528 Hz ; \ Song [7] Ham 12:00 11/01/92 \ Famous song by W. A. Mozart QTR C C G G A A HALF G QTR F F E E D D HALF C QTR G G F F E E HALF D QTR G G F F E E HALF D QTR C C G G A A HALF G QTR F F E E D D HALF C \ RASPBERRY and first BELL [7] Ham 12:00 11/01/92 : RASPBERRY 38 100 BEEP ; : BELL 440 15 BEEP ; \ The following values give different sounds for different \ error beeps: 260 25 2CONSTANT WARNING 760 50 2CONSTANT CRITICAL : BEWARE WARNING BEEP ; : DISASTER CRITICAL BEEP ; : WARBLE 5 0 DO 760 10 BEEP 380 10 BEEP LOOP ; \ HEX display [7] Ham 12:00 11/01/92 : SHOW-HEX ( n - 0 ) 0 HEX DO I . LOOP DECIMAL ; HEX FF 1 + SHOW-HEX \ HEX DEC is equal to DECIMAL 3564. \ When you enter 17 CONSTANT 5 you define a new constant with \ the name "5" (without the quotation marks) whose value is \ 17. Whenever 5 is executed, its value (17) is put on the \ stack--because Forth first looks a string up in the dictionary\ before trying to convert the string to a number. And after \ 17 CONSTANT 5 is executed, 5 is found in the dictionary and \ executed (as a constant) before it is ever tried as a number. \ More on HEX [7] Ham 12:00 11/01/92 \ In the definition DECIMAL : TEST HEX FA . ; the word HEX is \ not executed until TEST is executed. Thus the base is still \ DECIMAL (at compile-time) when FA is encountered. FA is not \ found in the dictionary, nor is it recognized as a (decimal) \ numeral. Therefore it shows as an error. \ The value of the base (using that base) is always represented \ by the numeral 10, which signifies 1 times the base number \ plus 0 units--whether the base is 2, 10, 16, or 23. : BASE-NOW BASE @ DUP DECIMAL . BASE ! ; \ BASE-NOW displays (in decimal) the value of the current base. \ Entering numerals [7] Ham 12:00 11/01/92 \ When you define a word A but enter 0A, then the string 0A is \ not found in the dictionary. Forth thereupon tries to convert\ it to a number. If you are in HEX, 0A does indeed represent \ a number and the conversion works. \ When you enter 20 characters in PAD after entering 40, you \ overlay only the first 20 of the original 40 characters. The \ final 20 characters remain unchanged. \ [8] CREATE TOM WSIZE ALLOT WSIZE ERASE works for both Forths \ : VARIABLE ( - ; name ) CREATE HERE WSIZE ALLOT WSIZE ERASE ; \ The above definition works for both 16-bit and 32-bit Forths. \ PAD defined; $VARIABLE ver 1 [8] Ham 12:00 11/01/92 : PAD ( - adr ) HERE 100 + ; CREATE USERNAME HERE 20 DUP ALLOT BLANK CR CR .( Enter your name: ) USERNAME 20 EXPECT CR CR .( Here is your name: ) USERNAME 20 TYPE \ Following is the first definition of $VARIABLE : $VARIABLE ( n - ; name ) CREATE HERE SWAP DUP ALLOT BLANK ; 20 $VARIABLE PROJECT CR PROJECT 20 TYPE CR .( Enter project name: ) PROJECT 20 EXPECT CR .( You entered: ) PROJECT 20 TYPE \ Saving the count in the count byte [8] Ham 12:00 11/01/92 20 $VARIABLE USERNAME CR CR .( Enter your name: ) USERNAME 1 + 19 EXPECT SPAN @ USERNAME C! CR CR .( Here is your name: ) USERNAME DUP 1 + SWAP C@ TYPE \ New definition of $VARIABLE (ver 2): : $VARIABLE ( n -; name) CREATE HERE SWAP 1 + DUP ALLOT BLANK ; : C+! ( n adr - ) DUP C@ ROT + SWAP C! ; \ If the byte at PAD contains 255, then 1 PAD C+! makes it 0. \ $IN .$ CRs [8] Ham 12:00 11/01/92 : MYCOUNT ( adr - adr+1 n ) DUP 1 + SWAP C@ ; : $IN ( adr count - ) OVER 1 + SWAP EXPECT SPAN @ SWAP C! ; : .$ ( adr - ) COUNT TYPE ; : BACKSPACES ( n - ) 0 ?DO 8 EMIT LOOP ; : MYCR 13 EMIT 10 EMIT ; : CRs ( n - ) 0 ?DO CR LOOP ; \ Display of character set; PRESS [8] Ham 12:00 11/01/92 : MYTYPE ( adr count - ) 0 DO COUNT EMIT LOOP DROP ; 256 32 2CONSTANT ALL \ define loop limits : CHARS1 ALL DO I EMIT LOOP ; : CHARS2 ALL DO I DUP . EMIT 2 SPACES LOOP ; : CHARS3 CR ALL DO 14 0 DO J I + DUP 3 .R EMIT SPACE LOOP CR 14 +LOOP ; : ^CHARS 32 0 DO I PAD C! PAD 1 TYPE SPACE LOOP ; : PRESS ." Press any key to continue." KEY DROP ; \ Testing BL and 32 [8] Ham 12:00 11/01/92 \ Load !TIMER and .TIMER from the file FORTH.SCR : TEST1 !TIMER 60000 0 DO BL DROP LOOP .TIMER ; : TEST2 !TIMER 60000 0 DO 32 DROP LOOP .TIMER ; CR .( Time for BL: ) TEST1 .( sec ) CR .( Time for 32: ) TEST2 .( sec ) CR HERE : ONE BL ; HERE SWAP - WSIZE - . .( bytes for BL ) CR HERE : TWO 32 ; HERE SWAP - WSIZE - . .( bytes for 32 ) \ WSIZE bytes are subtracted from the difference because they \ are contributed by ; rather than by BL or 32. \ New .$ and example [8] Ham 12:00 11/01/92 \ Display the name with USERNAME COUNT TYPE and with \ USERNAME 20 TYPE \ Revised .$ : .$ ( adr - ) COUNT -TRAILING TYPE ; 50 $VARIABLE USERNAME \ Note length: to show -TRAILING's power : GETNAME CR CR ." Enter name and press return: " USERNAME 50 $IN ; : .USER USERNAME .$ ; \ TRUE and FALSE [9] Ham 12:00 11/01/92 : TEST1 60000 !TIMER 60000 0 DO 1 - LOOP DROP .TIMER ; : TEST2 60000 !TIMER 60000 0 DO 1- LOOP DROP .TIMER ; \ -1 is a negative number: the result of 0 1 - for example. \ 1- is the operation of subtracting 1: 0 1- for example \ -1 CONSTANT TRUE 0 CONSTANT FALSE \ T and F are not so readable as TRUE and FALSE; moreover, if \ you are working in hex, you may have collisions with \ F--either you may forget to use 0 as a prefix in the number \ 0F and place 0 on the stack instead of the 15 you intended, \ or you may read F as 15 instead of 0 and confuse yourself in \ interpreting the source code. \ ON and OFF [9] Ham 12:00 11/01/92 : ON ( adr - ) TRUE SWAP ! ; : OFF ( adr - ) FALSE SWAP ! ; \ OFF is often used to zero variables without regard to its \ logical truth value. Both ON and OFF are frequently useful. \ Adding "true" to the contents of a variable decrements the \ contents by 1 VARIABLE SAM 15 SAM ! TRUE SAM +! SAM @ . \ .S and final version of BELL [9] Ham 12:00 11/01/92 : .S DEPTH DUP IF 0 DO SPACE DEPTH 1- I - PICK . LOOP ELSE DROP ." Stack empty" THEN SPACE ; \ The following version of BELL is useful. VARIABLE NOISE \ True means sound bell NOISE ON \ Default is to have the bell : BELL NOISE @ IF 440 20 BEEP THEN ; \ LUCK [9] Ham 12:00 11/01/92 : .S DEPTH ?DUP IF 0 DO SPACE DEPTH 1- I - PICK . LOOP ELSE ." Stack empty" THEN SPACE ; ( No DROP needed after ELSE ) : LUCK ( n - ) DEPTH IF ." You're " 3 <> IF ." not " THEN ." lucky." ELSE ." Please enter a number before LUCK." THEN ; \ NOT works bitwise and will produce all 0 bits ONLY if the \ original number had all 1 bits--i.e., was -1. 3 NOT still \ will have some bits on and thus will still be "true." \ .BITS [9] Ham 12:00 11/01/92 : .BITS ( n - ) CR BINARY DUP 8 WSIZE * U.R \ bits in original CR NOT 8 WSIZE * U.R SPACE DECIMAL ; \ bits after NOT CR 24 .BITS CR CR TRUE .BITS CR CR -17 .BITS CR CR \ TRUE TRUE AND is TRUE \ FALSE TRUE OR is TRUE \ TRUE FALSE XOR is TRUE \ New .BITS that leaves number on stack and BASE as it was: : .BITS ( n - n ) BASE @ OVER BINARY . BASE ! ; \ ?DUP >= <= [9] Ham 12:00 11/01/92 \ : ?DUP ( 0 - 0 | n - n n ) DUP IF DUP THEN ; \ Use the fact that IF will treat any nonzero number as "true" \ to eliminate an unnecessary 0<> in the definition. \ For any nonzero value, 0<> produces -1 ("true") \ For zero, 0<> produces 0 ("false") : >= ( n1 n2 - flag ) 2DUP > -ROT = OR ; \ Simpler definition of >= : >= < NOT ; : <= ( n1 n2 - flag ) 2DUP < -ROT = OR ; \ Simpler definition of <= : <= > NOT ; \ Final version of .S [9] Ham 12:00 11/01/92 \ This is the version of .S that I use. \ It prints unsigned numbers except for range -1 through -255. : .S DEPTH ?DUP IF 0 DO SPACE DEPTH I 1+ - PICK DUP -256 < IF U. ELSE . THEN LOOP ELSE ." zip" THEN SPACE ; : TEST1 !TIMER 60000 0 DO 5 0 = DROP LOOP .TIMER ." sec" ; : TEST2 !TIMER 60000 0 DO 5 0= DROP LOOP .TIMER ." sec" ; : TEST3 !TIMER 60000 0 DO 5 0 > DROP LOOP .TIMER ." sec" ; : TEST4 !TIMER 60000 0 DO 5 0> DROP LOOP .TIMER ." sec" ; CR CR .( 0 = ) TEST1 CR .( 0= ) TEST2 CR .( 0 > ) TEST3 CR .( 0> ) TEST4 CR \ Combining truth values ODD? EVEN? [9] Ham 12:00 11/01/92 : 1-37 ( n - f ) DUP 1 > SWAP 37 < AND ; \ true if 1 < n < 37 : <2OR36> ( n - f ) DUP 2 < SWAP 36 > OR ; \ true if n < 2 \ or n > 36 : 1,3,5,9? ( n - f ) DUP 1 = OVER 3 = OR OVER 5 = OR SWAP 9 = OR ; \ true if n is 1, 3, 5, or 9 : ODD? ( n - f ) 1 AND 0<> ; \ true if top of stack is odd : EVEN? ( n - f ) ODD? NOT ; \ true if top of stack is even : ASCII># ( c - # ) DUP 48 < OVER 57 > OR ?DUP IF NIP ELSE 48 - THEN ; \ if not ASCII digit, leave -1. \ S>B U0> NEGATE ABS [9] Ham 12:00 11/01/92 \ S>B converts a single-precision number to a boolean flag : S>B ( n - flag ) 0<> ; \ force nonzero to -1 \ U0> makes no sense: unsigned numbers are either zero or \ positive. U0> is in effect nothing more than 0<>. \ : NEGATE ( n - -n ) -1 * ; \ : NEGATE ( n - -n ) 0 SWAP - ; \ which is faster? \ : ABS ( n - |n| ) DUP 0< IF NEGATE THEN ; \ ABS is short for "absolute value": the value of the number \ considered as a nonnegative. \ Using MOD and counting by 3 [10] Ham 12:00 11/01/92 : 16MODS 100 0 DO I 16 MOD . LOOP ; \ show results of 16 MOD : DISPLAY ( n - ) HEX 0 ?DO I DUP 16 MOD 0= IF CR THEN 3 .R LOOP DECIMAL ; \ Note that HEX executes at run-time, \ not at compile-time. : DISPLAY2 ( n - ) 0 ?DO I DUP BASE @ MOD 0= IF CR THEN 3 .R LOOP ; : COUNTDOWN ( n - ) CR 0 SWAP ?DO I . -1 +LOOP ." Blastoff! " ; \ Counting by 3's: Try 30 BY3 and -30 BY3 : BY3 ( n - ) CR DUP 0> IF 1+ THEN DUP 0 ?DO I . DUP 0< IF -3 ELSE 3 THEN +LOOP DROP ; \ Leaving a loop [10] Ham 12:00 11/01/92 .( Press key to quit when running TEST ) : TEST 16000 0 DO I . ?TERMINAL IF KEY DROP LEAVE THEN LOOP ; : BL? ( n - flag ) BL = ; : TEST2 CLS ." Press space to quit; other keys won't." CR 16000 0 DO I . ?TERMINAL IF KEY BL? IF LEAVE THEN THEN LOOP ; : CR? ( n - flag ) 13 = ; : TEST3 CLS ." Press space bar or Enter to quit." 16000 0 DO I . ?TERMINAL IF KEY DUP BL? OVER CR? OR IF LEAVE THEN THEN LOOP ; \ NUF? version 1 PCKEY PRESS [10] Ham 12:00 11/01/92 27 CONSTANT Esc : Esc? ( n - flag ) Esc = ; : NUF? ( - f ) ?TERMINAL DUP IF KEY 2DROP KEY Esc? THEN ; : TEST4 16000 0 DO I . NUF? IF LEAVE THEN LOOP ; : PCKEY ( -- ASCII-char -1 | IBM-special_char 0 ) KEY ?DUP IF TRUE ELSE KEY FALSE THEN ; \ PCKEY is an essential word--keep it in TOOLS.SCR : PRESS ." Press any key to continue." PCKEY 2DROP ; \ NUF? version 2 F1? HOME? PGUP? LEFT? [10] Ham 12:00 11/01/92 : NUF? ( - f ) ?TERMINAL DUP IF PCKEY 2DROP DROP PCKEY IF Esc? ELSE DROP FALSE THEN THEN ; \ This version of NUF? is immune to pressing special key (e.g., \ a function key) and is the preferred version. : F1? ( n - flag ) 59 = ; : HOME? ( n - flag ) 71 = ; : PGUP? ( n - flag ) 73 = ; : LEFT? ( n - flag ) 75 = ; \ CASE example [10] Ham 12:00 11/01/92 : TESTCASE PCKEY IF ASCII A - CASE 0 OF ." A" ENDOF 1 OF ." B" ENDOF ." C or other" ENDCASE ELSE ." Special" DROP THEN ." key pressed." ; \ Need a DROP in the ELSE clause to get rid of the key value. \ An array of numbers [11] Ham 12:00 11/01/92 \ The phrase ] 5 6 7 [ puts not only the values 5 6 and 7 into \ the dictionary, but also the address of the word executed at \ run-time that puts the values on the stack. For instance, \ in the word : TEST 6 7 ; the values 6 and 7 at compile-time \ are put (as literals) into the dictionary. But when TEST is \ executed and the words in its definition are executed in turn,\ the values are placed on the stack. The word that does that \ placement is automatically put into a definition whenever a \ literal value is encountered. \ To store an array of numbers only, without the extra address, \ use , as shown: CREATE NOS. 5 , 6 , 7 , \ Constants for months, arrays for days [11] Ham 12:00 11/01/92 0 CONSTANT JAN 3 CONSTANT APR 6 CONSTANT JUL 9 CONSTANT OCT 1 CONSTANT FEB 4 CONSTANT MAY 7 CONSTANT AUG 10 CONSTANT NOV 2 CONSTANT MAR 5 CONSTANT JUN 8 CONSTANT SEP 11 CONSTANT DEC \ Note that FEB and DEC are also a HEX numerals. To avoid \ collisions always prefix hex numerals with 0. 0FEB and 0DEC \ will not collide with the constants named FEB and DEC. CREATE MAX-DAYS 31 C, 29 C, 31 C, 30 C, 31 C, 30 C, 31 C, 31 C, 30 C, 31 C, 30 C, 31 C, : DAYS ( mon - max-days ) MAX-DAYS + C@ ; \ Y/N ver 1 CAPITALIZE [11] Ham 12:00 11/01/92 : Y/N ( - Y | N ) BEGIN PCKEY IF DUP ASCII Y <> OVER ASCII N <> AND IF DROP FALSE ELSE TRUE THEN ELSE DROP FALSE THEN UNTIL ; : CAPITALIZE ( char - CHAR ) DUP ASCII a >= OVER ASCII z <= AND IF BL - THEN ; \ BL happens to have the value need to convert lower-case to \ to upper. As a constant, it is more compact than literal 32. \ Y/N ver 2 [11] Ham 12:00 11/01/92 \ The following includes CAPITALIZE and also BELL. \ To hear the BELL execute NOISE ON before running Y/N. : Y/N ( - Y | N ) BEGIN PCKEY IF CAPITALIZE DUP ASCII Y <> OVER ASCII N <> AND IF DROP BELL FALSE ELSE TRUE THEN ELSE DROP BELL FALSE THEN UNTIL ; \ In the definition of COUNTBACK, a DROP is needed after REPEAT \ to leave the stack clean. : COUNTBACK 10 BEGIN 1- DUP WHILE DUP . REPEAT DROP ; \ Y/N ver 3 [11] Ham 12:00 11/01/92 : @KEY ( - ASCII-key ) BEGIN PCKEY NOT WHILE DROP BELL REPEAT ; \ @KEY is useful when all "special" keys are invalid. : Y/N ( - Y | N ) BEGIN @KEY CAPITALIZE DUP ASCII Y <> OVER ASCII N <> AND WHILE DROP BELL REPEAT ; : YES? ( - flag ) Y/N ASCII Y = ; : NO? ( - flag ) YES? NOT ; \ Y/N ver 4 (the one I use the most) [11] Ham 12:00 11/01/92 : BACKSPACE 8 EMIT ; : ECHO ( n - n ) DUP 31 > IF DUP EMIT BACKSPACE THEN ; \ ECHO will echo to the screen only non-control characters, \ and then backspaces to keep the cursor in place. (If you \ emit control characters, odd things can happen.) : Y/N ( - flag ) ." (Y/N)? " BEGIN @KEY CAPITALIZE ECHO DUP ASCII Y <> OVER ASCII N <> AND WHILE DROP BELL REPEAT DUP EMIT ASCII Y = ; \ This version of Y/N is the one that I use the most; the final \ DUP EMIT is to overcome the backspace in ECHO; it's not \ actually needed when Y/N is used in a program. \ Y/N ver 5 [11] Ham 12:00 11/01/92 : CR? 13 = ; : REKEY ( n - n ) BEGIN CAPITALIZE ECHO DUP ASCII Y <> OVER ASCII N <> AND WHILE BELL DROP @KEY REPEAT ; : Y/N ( - flag ) ." (Y/N)? " ASCII Y ECHO @KEY DUP CR? IF DROP ECHO ELSE NIP REKEY THEN DUP EMIT ASCII Y = ; \ This Y/N has a default Y value: if the user presses Enter, \ Y is assumed. \ Y/N ver 6 [11] Ham 12:00 11/01/92 : Y/N ( flag - flag ) ." (Y/N)? " IF ASCII Y ELSE ASCII N THEN ECHO @KEY DUP CR? IF DROP ECHO ELSE NIP REKEY THEN DUP EMIT ASCII Y = ; \ The above shows default Y if true flag, else default N. \ Flag could come from the previous response (perhaps stored \ in a variable). \ : CAPITALIZE ( c - C ) 95 AND ; is not an elegant solution, \ it's just a cheap trick. Why? It doesn't work in all cases. \ Try this definition not only with letters, but also with \ numerals. To see how and why it works, look at the bits. \ THRU PLAIN FANCY [12] Ham 12:00 11/01/92 \ If 5 10 THRU is at the bottom of screen 5 and you execute \ 5 LOAD, you will get caught in a loop, repeatedly loading \ screen 5. Screen 5 will load down to the phrase 5 10 THRU, \ which then begins loading screens 5 through 10; when the \ phrase 5 10 THRU is again encountered, again the loading \ begins with screen 5. And so on. \ : THRU ( n1 n2 - ) 1+ SWAP DO I LOAD LOOP ; : PLAIN ( # - ) WSIZE * OPTIONS + PERFORM ; \ show plain : FANCY ( # - ) REVERSE PLAIN -REVERSE ; \ show inverse \ SHOWALL [12] Ham 12:00 11/01/92 \ SHOWALL leaves the default option on the stack. : SHOWALL ( # - # ) #OPTS 0 DO I 2DUP = IF FANCY ELSE PLAIN THEN LOOP ; \ 9 6 MOD is 3. -2 6 MOD is 4. -3 6 MOD is 3. \ If all options are in a column, then when RIGHT and LEFT are \ pressed the number of options is added to the current option. \ When the result is taken MOD the number of options, the \ original number results. Example: suppose there are 7 \ options in a column, with cursor on 3. When RIGHT is pressed,\ the result is to add 7 to 3, giving 10, and then 10 7 MOD \ gives the result 3--the original number. \ UP DOWN RIGHT LEFT [12] Ham 12:00 11/01/92 \ Assuming the option number is on the stack, when UP is \ pressed, we would do the following: : UP ( # - #' ) DUP PLAIN 1- #OPTS MOD DUP FANCY ; : DOWN ( # - #' ) DUP PLAIN 1+ #OPTS MOD DUP FANCY ; : RIGHT ( # - #' ) DUP PLAIN #/COL + #OPTS MOD DUP FANCY ; : LEFT ( # - #' ) DUP PLAIN #/COL - #OPTS MOD DUP FANCY ; \ Note the similarities. They suggest that the programmer \ think how to write the code to minimize duplication. \ Alternative RIGHT and LEFT [12] Ham 12:00 11/01/92 : FOLDRT ( # - #' ) #OPTS #/COL = IF 1+ ELSE #/COL + THEN ; : RIGHT ( # - #' ) DUP PLAIN FOLDRT #OPTS MOD DUP FANCY ; : FOLDLF ( # - #' ) #OPTS #/COL = IF 1- ELSE #/COL - THEN ; : LEFT ( # - #' ) DUP PLAIN FOLDLF #OPTS MOD DUP FANCY ; \ The above work as RIGHT and LEFT in multi-column menus and \ as DOWN and UP respectively in single-column menus. \ *****>>>>> For the remaining exercises regarding menus, \ *****>>>>> see the file MENUS.SCR. \ END CRs TITLE [13] Ham 12:00 11/01/92 : END ( - # ) ?SCREENS 1- ; 0 CONSTANT FIRST : TO ; : CRs ( n - ) 0 ?DO CR LOOP ; : TITLE 6 CRs 10 SPACES ." My Address Book" 10 SPACES .DATE 3 SPACES .TIME CR CR ; 0 EQU LINE# \ These words must be defined before 0 EQU ENTRY# \ they can be used in a definition. 0 EQU PAGE# : TITLE TITLE 8 EQU LINE# ; \ new version to set LINE# \ Note that the first line on page is line 0. --> \ INITIALIZE .PAGE [13] Ham 12:00 11/01/92 : INITIALIZE USING PEOPLE PRINTER TITLE 0 EQU ENTRY# ; : TO60 60 LINE# ?DO CR LOOP ; \ space to line 60 : INITIALIZE USING PEOPLE PRINTER TITLE 0 EQU ENTRY# 1 EQU PAGE# ; : TO59 59 OUT @ - SPACES ; \ space to position 59 : .PAGE ." Page" PAGE# 3 .R ; \ 3 .R to get blank after "Page" PAGE# 1+ EQU PAGE# \ increment PAGE# by 1 --> \ PRINT-ENTRY RETRIEVE? [13] Ham 12:00 11/01/92 4 CONSTANT #/BLOCK \ no. of entries per block 4 CONSTANT LINES/ENTRY \ no. of lines per entry 64 CONSTANT CHARS/LINE \ no. of characters per line CHARS/LINE LINES/ENTRY * CONSTANT CHARS/ENTRY : PRINT-ENTRY ( adr - ) DUP [ 3 ( lines ) CHARS/LINE * ] LITERAL + SWAP DO 10 SPACES I CHARS/LINE -TRAILING TYPE CR CHARS/LINE +LOOP CR ( 4th line ) LINE# LINES/ENTRY + EQU LINE# \ update line number ENTRY# 1+ EQU ENTRY# ; \ and entry number : RETRIEVE? ( n - adr flag ) #/BLOCK /MOD BLOCK SWAP CHARS/ENTRY * + ( adr of entry ) DISK-ERR @ 0= ; --> \ ANOTHER? PAGE FOOTER [13] Ham 12:00 11/01/92 : ANOTHER? ( - adr flag ) ENTRY# RETRIEVE? OVER C@ BL > AND ; : PAGE 12 EMIT ; : FOOTER 60 LINE# ?DO CR LOOP \ get to bottom of page 10 SPACES \ left margin ." File: " SCRHCB .FNAME \ print filename 59 OUT @ - SPACES \ move to print flush right .PAGE \ print page number PAGE# 1+ EQU PAGE# \ increment page number PAGE ; \ feed form to new page --> \ NO-ROOM? ENTRY TEST? OUTPUT [13] Ham 12:00 11/01/92 : NO-ROOM? ( - flag ) \ true if not enough lines left on page 60 LINE# - LINES/ENTRY < ; : ENTRY NO-ROOM? IF FOOTER TITLE THEN PRINT-ENTRY ; TRUE EQU TEST? \ TEST? leaves flag to indicate test status : OUTPUT TEST? IF CONSOLE ELSE PRINTER THEN ; \ So long as TEST? is true, output goes to the screen, not the \ printer. When you are happy with the program, make TEST? \ false, and output will go to the printer. Switches like this \ allow you to run a program in "test" or "production" mode. --> \ RUN (final routine) [13] Ham 12:00 11/01/92 \ This version does NOT print if the file contains no entries. : RUN USING PEOPLE 1 EQU PAGE# 0 EQU ENTRY# ANOTHER? IF OUTPUT TITLE BEGIN ENTRY ANOTHER? NOT UNTIL DROP ( final address ) FOOTER CONSOLE ELSE DROP ( adr ) CR ." No entries in file." THEN ; \ [14] To blank out PEOPLE.SCR: \ : ZAP-PEOPLE USING PEOPLE.SCR \ ?SCREENS 0 DO I BLOCK 1024 BLANK UPDATE LOOP FLUSH ; \ The final FLUSH is to ensure that the last block is written. \ $GET sequence OFFSET LEFTMOST? etc. [14] Ham 12:00 11/01/92 0 EQU CHARS \ maximum number of characters to collect 0 EQU STRING \ address of first byte of string storage \ (past the count byte if any) 0 EQU X \ x-coordinate (col) of original cursor locn 0 EQU Y \ y-coordinate (row) of original cursor locn : OFFSET ( - n ) ?XY DROP X - ; \ current offset into string : LEFTMOST? ( - flag ) OFFSET 0= ; \ true = left end : RIGHTMOST? ( - flag ) OFFSET CHARS 1- = ; \ true = right end \ Load this screen to get all screens for $GET (1st version). --> \ BACK BELL LEFT RIGHT [14] Ham 12:00 11/01/92 : BACK 8 EMIT ; \ Note that 8 EMIT is non-destructive: it \ does not rub out the character. VARIABLE NOISE NOISE ON \ true = sound bell; default: "on" : BELL NOISE @ IF 440 25 BEEP THEN ; : LEFT LEFTMOST? IF BELL ELSE BACK THEN ; : RIGHT RIGHTMOST? IF BELL ELSE ?XY SWAP 1+ SWAP GOTOXY THEN ; --> \ CURSOR INS PCKEY [14] Ham 12:00 11/01/92 : BIGCUR 0 14 SET-CUR ; \ block cursor for insert mode : SMLCUR 6 7 SET-CUR ; \ line cursor for overtype mode : NO-CUR 14 0 SET-CUR ; \ no cursor for menu selection VARIABLE INS? \ true if insert mode : CURSOR INS? @ IF BIGCUR ELSE SMLCUR THEN ; : INS INS? @ 0= INS? ! CURSOR ; \ toggle INS? & reset cursor : PCKEY ( -- ASCII-char -1 | IBM-special_char 0 ) KEY ?DUP IF TRUE ELSE KEY FALSE THEN ; --> \ HOME SETUP OVERTYPE [14] Ham 12:00 11/01/92 : HOME X Y GOTOXY ; \ go to first position of field : SETUP ( adr cnt - ) EQU CHARS EQU STRING ?XY EQU Y EQU X STRING CHARS TYPE \ display current string CURSOR HOME ; \ put correct cursor at start of string : OVERTYPE ( c - ) RIGHTMOST? SWAP \ save flag for later DUP STRING OFFSET + C! EMIT IF ( rightmost ) BELL BACK THEN ; --> \ PULL MOVE [14] Ham 12:00 11/01/92 : PULL STRING OFFSET + \ current loc in string: destination DUP 1+ \ 1st char past current loc: source SWAP \ put source and dest in order CHARS OFFSET - \ # of chars from cursor to right 1- \ # of chars strictly right of cursor CMOVE \ copy chars and then BL STRING CHARS 1- + C! ; \ blank out rightmost positn : MOVE ( source dest cnt - ) 0 2OVER U< NIP ( the 0 ) IF CMOVE> ELSE CMOVE THEN ; \ MOVE uses the correct move; U< because comparing addresses. \ 0 used in definition was just so 2OVER would work. --> \ PUSH REFRESH DELETE [14] Ham 12:00 11/01/92 : PUSH STRING OFFSET + \ current location in string DUP 1+ \ 1st char past current location CHARS OFFSET - \ # of chars from cursor to right 1- \ # of chars strictly right of cursor CMOVE> ; \ copy characters from right : REFRESH ?XY OFFSET DUP STRING + ( adr ) CHARS ROT - ( # of char ) TYPE GOTOXY ; \ The x and y coordinates are parked on the stack \ until they are needed at the end. : DELETE PULL REFRESH ; --> \ BACKSPACE INSERT [14] Ham 12:00 11/01/92 : BACKSPACE LEFTMOST? IF BELL ELSE BACK DELETE THEN ; : PUSHED? ( - f ) STRING CHARS 1- + C@ BL <> ; \ true if character in last location is nonblank & thus \ pushed off end; defined separately for readability and \ for use in a later version of INSERT : INSERT ( c - ) RIGHTMOST? IF OVERTYPE ELSE PUSHED? IF BELL ( character pushed off ) THEN PUSH STRING OFFSET + C! REFRESH RIGHT THEN ; --> \ TAIL END LEGAL? [14] Ham 12:00 11/01/92 : TAIL ( - offset ) \ leave offset for END; 1 past last char STRING CHARS -TRAILING NIP CHARS 1- MIN ; : END X TAIL + Y GOTOXY ; : LEGAL? ( c - flag ) DUP 31 > SWAP 127 < AND ; \ leave "true" for characters from blank through ~ --> \ Key equivalence constants [14] Ham 12:00 11/01/92 \ The following constants will be generally useful 71 CONSTANT HOMEKEY 82 CONSTANT INSKEY 79 CONSTANT ENDKEY 83 CONSTANT DELKEY 75 CONSTANT LEFTKEY 72 CONSTANT UPKEY 77 CONSTANT RIGHTKEY 80 CONSTANT DOWNKEY 59 CONSTANT F1KEY 81 CONSTANT PGDNKEY 15 CONSTANT LTABKEY 73 CONSTANT PGUPKEY 9 CONSTANT TABKEY 27 CONSTANT ESCKEY 13 CONSTANT ENTERKEY 8 CONSTANT BSPKEY \ TABKEY, ESCKEY, ENTERKEY, and BSPKEY are all ASCII values. \ Others are "special" IBM keys --> \ REGULAR SPECIAL [14] Ham 12:00 11/01/92 : REGULAR ( c - flag ) DUP LEGAL? IF INS? @ IF INSERT ELSE OVERTYPE THEN FALSE ELSE CASE BSPKEY OF BACKSPACE FALSE ENDOF ENTERKEY OF TRUE ( quits ) ENDOF BELL FALSE SWAP ENDCASE THEN ; : SPECIAL ( c - 0 ) CASE HOMEKEY OF HOME ENDOF LEFTKEY OF LEFT ENDOF RIGHTKEY OF RIGHT ENDOF DELKEY OF DELETE ENDOF INSKEY OF INS ENDOF ENDKEY OF END ENDOF BELL ENDCASE FALSE ; --> \ $GET $GETC [14] Ham 12:00 11/01/92 : $GET ( adr count - ) REVERSE SETUP BEGIN PCKEY IF ( regular key ) REGULAR ELSE ( special key ) SPECIAL THEN UNTIL -REVERSE ; : $GETC ( adr count - ) \ assumes count byte is located at the address STRING-1 $GET CHARS STRING 1- C! ; \ $GETC stores the maximum string count; trailing blanks can \ easily be trimmed with -TRAILING, and in some cases it may \ be useful to know how long the string can be--never discard \ information unless you have to. \ New version of DELETE [14] Ham 12:00 11/01/92 \ DELETE is redefined to make it act as backspace after every- \ thing above and to the right of the cursor has been deleted. : DELETE TAIL 1- OFFSET < IF LEFTMOST? NOT IF BACK THEN THEN PULL REFRESH ; \ Must now redefine SPECIAL to include new definition of DELETE : SPECIAL ( c - 0 ) CASE HOMEKEY OF HOME ENDOF LEFTKEY OF LEFT ENDOF RIGHTKEY OF RIGHT ENDOF DELKEY OF DELETE ENDOF INSKEY OF INS ENDOF ENDKEY OF END ENDOF BELL ENDCASE FALSE ; \ Load this screen to get new version of $GET with new DELETE. --> \ And new $GET to use new SPECIAL [14] Ham 12:00 11/01/92 \ New version of $GET with seek-and-destroy DELETE: : $GET ( adr count - ) REVERSE SETUP BEGIN PCKEY IF ( regular key ) REGULAR ELSE ( special key ) SPECIAL THEN UNTIL -REVERSE ; \ Notice that $GET reads exactly as before; it is redefined \ soley to incorporate the new definition of SPECIAL. \ No beep 1st time in last position I [14] Ham 12:00 11/01/92 \ This screen and the next contain revisions of earlier \ definitions that will prevent the bell sounding when \ first entering a character in the last position. VARIABLE FIRST \ true after first character in last position : BACK 8 EMIT FIRST OFF ; : HOME X Y GOTOXY FIRST OFF ; : DELETE DELETE FIRST OFF ; \ Delete ensures that last position is blank. \ No beep 1st time in last position II [14] Ham 12:00 11/01/92 : OVERTYPE ( c - ) RIGHTMOST? SWAP ( save the flag for later ) DUP STRING OFFSET + C! EMIT IF ( rightmost ) FIRST @ IF BELL THEN BACK FIRST ON THEN ; \ This OVERTYPE will not sound bell for the first character \ entered in the last position but will for subsequent chars. : INSERT ( c - ) RIGHTMOST? IF FIRST @ NOT PUSHED? AND IF BELL THEN OVERTYPE ELSE PUSHED? IF BELL ( character pushed off ) THEN PUSH STRING OFFSET + C! REFRESH RIGHT THEN ; \ In INSERT we want bell if a char is pushed off the end \ (even on first keystroke there)--but not >two< bells! \ So we must work around the bell sounded in the OVERTYPE \ used in the definition of INSERT. \ GETENTRY development: SLOT [15] Ham 12:00 11/01/92 200 CONSTANT MAXRECS \ maximum number of records allowed 138 CONSTANT RECSIZE \ number of bytes per record CREATE WORKAREA MAXRECS RECSIZE * ALLOT \ Be careful not to load multiple copies of WORKAREA. At \ 27,600 bytes, two copies on top of your regular dictionary \ will overflow the dictionary space and crash the system. : SLOT ( n - adr ) RECSIZE * WORKAREA + ; : INCR ( adr - ) 1 SWAP +! ; --> \ #RECS CHANGE GETFNAME [15] Ham 12:00 11/01/92 VARIABLE #RECS \ number of records currently in work area VARIABLE CHANGE \ true = work area contents have been changed CREATE FILE 33 ALLOT \ blanked in OPEN-FILE : GETFNAME FILE 1+ 32 $GETC FILE COUNT -TRAILING FILE C! DROP ; : @KEY ( - ASCII-key ) BEGIN PCKEY NOT WHILE DROP BELL REPEAT ; : CAPITALIZE ( char - CHAR ) DUP ASCII a >= OVER ASCII z <= AND IF BL - THEN ; \ BL takes less room than a literal 32. : Y/N ( - flag ) ." (Y/N)? " BEGIN @KEY CAPITALIZE DUP 31 > IF DUP EMIT 8 EMIT THEN DUP ASCII Y <> OVER ASCII N <> AND WHILE DROP BELL REPEAT ASCII Y = ; --> \ SCRTITLE OPEN-FILE [15] Ham 12:00 11/01/92 : SCRTITLE 33 0 GOTOXY ." My Address Book" FILE COUNT 40 OVER 2/ - 2 GOTOXY TYPE ; : OPEN-FILE CLS FILE 33 BLANK ( initialize area ) SCRTITLE BEGIN 10 10 GOTOXY ." Enter name of address file: " GETFNAME FILE OPEN-SCR WHILE ( failed ) CR CR 10 SPACES BELL ." No file found with name " FILE COUNT TYPE ." ." CR CR 10 SPACES ." Do you want to re-enter the name " Y/N IF 0 12 GOTOXY CLREOL 0 14 GOTOXY CLREOL FILE 33 BLANK ( try again) ELSE ABORT" Goodbye." THEN REPEAT ; --> \ RECORD GETFILE [15] Ham 12:00 11/01/92 7 CONSTANT #/BLOCK \ 7 records per block : RECORD ( n - adr ) #/BLOCK /MOD BLOCK SWAP RECSIZE * + ; : GETFILE #RECS OFF CHANGE OFF ?SCREENS #/BLOCK * 0 DO I RECORD DUP C@ BL = IF DROP LEAVE THEN I SLOT RECSIZE CMOVE #RECS INCR #RECS @ MAXRECS = IF LEAVE THEN LOOP CLOSE-SCR ; \ cut off at maximum no. of records \ For PUTFILE, see next screen. PUTFILE needs to include \ blanking out NEW, the area for a new record. --> \ NEW PUTFILE [15] Ham 12:00 11/01/92 CREATE NEW RECSIZE ALLOT \ work area for one new record : 2CR CR CR ; \ just to save a little room : >FIELD ( - adr ) 13 OUT @ - SPACES REVERSE NEW ; \ >FIELD is a nonce word to save room in a definition; it \ contains repeated commands used in NEW-ENTRY. : PUTFILE CHANGE @ IF FILE OPEN-SCR DROP ( status ) #RECS @ 0 ?DO I SLOT I RECORD RECSIZE CMOVE UPDATE LOOP BL #RECS @ RECORD C! \ mark end of active records UPDATE FLUSH CLOSE-SCR CHANGE OFF THEN NEW RECSIZE BLANK ; --> \ NEW-ENTRY [15] Ham 12:00 11/01/92 : NEW-ENTRY SCRTITLE 27 4 GOTOXY ." New Address Entry Screen" 2CR ." Number of record slots remaining:" MAXRECS #RECS @ - 5 .R 2CR ." Last Name:" >FIELD 16 TYPE -REVERSE 2CR ." First Name:" >FIELD 16 + 12 TYPE -REVERSE 2CR ." Address 1:" >FIELD 28 + 30 TYPE -REVERSE 2CR ." Address 2:" >FIELD 58 + 30 TYPE -REVERSE 2CR ." City:" >FIELD 88 + 25 TYPE -REVERSE 2CR ." State:" >FIELD 113 + 2 TYPE -REVERSE 2CR ." ZIP:" >FIELD 115 + 10 TYPE -REVERSE 2CR ." Telephone:" >FIELD 125 + 13 TYPE -REVERSE 2CR 29 SPACES ." Press F1 for help." 13 8 GOTOXY ; --> \ PRESS HELP [15] Ham 12:00 11/01/92 : PRESS NO-CUR ." Press any key to continue." PCKEY 2DROP ; \ Turn off cursor to improve display. : HELP ?XY -REVERSE ( executed within inversed data field ) CLS SCRTITLE 26 6 GOTOXY ." Enter data as labeled." 22 8 GOTOXY ." Leading blanks are not accepted." 28 12 GOTOXY ." Have a nice day. " 1 EMIT 25 21 GOTOXY PRESS CLS NEW-ENTRY GOTOXY REVERSE CURSOR ; \ Note dopey attempt at "user-friendliness" with smiley face. \ There's more than that to writing a user-friendly program. --> \ WHICH POSITION-CURSOR version 1 [16] Ham 12:00 11/01/92 VARIABLE WHICH \ current entry field number \ Task: position the cursor appropriately, using WHICH. \ Three versions are developed. \ First, an array of x and y coordinates: CREATE CSPOTS 13 8 , , 13 10 , , 13 12 , , 13 14 , , 13 16 , , 13 18 , , 13 20 , , 13 22 , , : POSITION-CURSOR WHICH @ WSIZE 2* ( WSIZE bytes/number ) * CSPOTS + 2@ GOTOXY ; --> \ POSITION-CURSOR ver 2 & 3 [16] Ham 12:00 11/01/92 \ Next, noting that every x coordinate is 13: CREATE Y'S 8 , 10 , 12 , 14 , 16 , 18 , 20 , 22 , : POSITION-CURSOR 13 ( x crd ) WHICH @ WSIZE * Y'S + @ GOTOXY ; \ Finally, noting the pattern of the y coordinates, we see \ that we don't need an array at all. : POSITION-CURSOR 13 ( x coord ) WHICH @ 2* 8 + GOTOXY ; \ Never be satisfied with the first solution. --> \ ADDR-LENGTH ver 1 [16] Ham 12:00 11/01/92 \ Task: put appropriate address (within NEW) and length (of \ string) of the current datum on the stack based on \ contents of WHICH. \ Using an array of addresses and lengths of each entry field: CREATE A/L NEW 16 , , NEW 16 + 12 , , NEW 28 + 30 , , NEW 58 + 30 , , NEW 88 + 25 , , NEW 113 + 2 , , NEW 115 + 10 , , NEW 125 + 13 , , : ADDR-LENGTH ( - adr n ) WHICH @ WSIZE 2* * A/L + 2@ ; --> \ ADDR-LENGTH ver 2 [16] Ham 12:00 11/01/92 \ The following approach exploits the fact that the length of \ a field can be obtained from knowing the first position of \ the field and the first position of the next field following. \ This array simply stores the first position of every field \ (and the first position beyond the last field for the final \ subtraction), retrieves two of the addresses, and computes. \ Slower, but uses fewer bytes because array is smaller. CREATE A/L2 NEW DUP , 16 + DUP , 12 + DUP , 30 + DUP , 30 + DUP , 25 + DUP , 2 + DUP , 10 + DUP , 13 + , : ADDR-LENGTH ( - adr n ) WHICH @ WSIZE * A/L2 + 2@ TUCK - ; --> \ LEGALKEYS [16] Ham 12:00 11/01/92 : LEGALKEYS ( c - flag ) DUP 31 > OVER 127 < AND SWAP BL = OFFSET 0= AND NOT AND ; \ Above makes blank in first position illegal for all fields. \ \ : LEGALKEYS ( c - flag ) DUP 31 > OVER 127 < AND \ SWAP BL = OFFSET 0= AND WHICH @ 0= AND NOT AND ; \ \ Above makes blank in first position illegal only in field 0. \ Changing GETENTRY to initialize $GET and REGKEYS: see \ screen at the end of this sequence (screen 96). --> \ UP DOWN ESCAPE [16] Ham 12:00 11/01/92 : DECR ( adr - ) -1 SWAP +! ; : UP ( - flag ) WHICH @ DUP IF WHICH DECR ELSE BELL THEN ; \ UP uses nonzero as a true flag--harmless enough if the \ flag is not being used except by IF or UNTIL or WHILE. 7 CONSTANT LASTFIELD \ last data-entry field (telephone) : DOWN ( - flag ) WHICH @ LASTFIELD <> DUP IF WHICH INCR ELSE BELL THEN ; VARIABLE DONE \ true = finished getting new entries : ESCAPE ( - flag ) DONE ON TRUE ; --> \ Two vers of ALL-BLANK? [16] Ham 12:00 11/01/92 \ Two versions: one with DO LOOP and one with STRCMP : ALL-BLANK? ( - flag) TRUE NEW DUP 16 + SWAP DO I C@ BL <> IF DROP ( true flag) FALSE LEAVE THEN LOOP ; : TEST1 !TIMER 10000 0 DO ALL-BLANK? DROP LOOP .TIMER ; : ALL-BLANK? ( - flag) PAD 16 BLANK PAD 16 NEW 16 STRCMP 0= ; : TEST2 !TIMER 10000 0 DO ALL-BLANK? DROP LOOP .TIMER ; \ Execute TEST1 and TEST2 to see which ALL-BLANK? is faster. --> \ Explanation of screen order [16] Ham 12:00 11/01/92 --> ENTER uses SAVE-RECORD, which uses FIND-SPOT !RECORD and CLEAR-ENTRY. So before entering the definition of ENTER (in the 5th screen following this screen), I first define the prerequisite words in the next four screens: Screen 88 and 89: Two definitions of FIND-SPOT Screen 90: !RECORD Screen 91: CLEAR-ENTRY and SAVE-RECORD Screen 92: DELFIRST FIXLAST and ENTER The screens therefore do not follow the exposition in the book, which is top down (while screens are defined bottom-up). \ AFTER? FIND-SPOT with variables [16] Ham 12:00 11/01/92 : AFTER? ( n - flag ) SLOT 28 NEW 28 STRCMP 0< ; VARIABLE LOW \ low slot number VARIABLE HIGH \ high slot number : FIND-SPOT ( - n ) \ leave no. of slot in which to insert NEW #RECS @ DUP IF LOW OFF 1- HIGH ! \ initialize variables BEGIN LOW @ HIGH @ 2DUP < WHILE + 2/ DUP AFTER? IF 1+ LOW ELSE HIGH THEN ! REPEAT DROP ( high ) DUP ( low ) AFTER? IF 1+ THEN THEN ; \ If #RECS = 0, the extra copy of 0 is left as the slot number. --> \ FIND-SPOT without variables [16] Ham 12:00 11/01/92 \ FIND-SPOT locates correct position for new record; this \ version uses no variables. FIND-SPOT is needed for \ SAVE-RECORD which is needed for ENTER. : FIND-SPOT ( - n ) \ leave no. of slot in which to insert NEW #RECS @ DUP IF 1- 0 SWAP \ low and high slot BEGIN 2DUP < WHILE 2DUP + 2/ DUP AFTER? IF ROT DROP 1+ ( low + 1 ) SWAP ELSE NIP ( high ) THEN REPEAT DROP ( high ) DUP ( low ) AFTER? IF 1+ THEN THEN ; --> \ SLIDE TRANSFER !RECORD [16] Ham 12:00 11/01/92 \ If WORKAREA has no records, 0 characters are moved by SLIDE. : SLIDE ( n - ) \ n = slot into which record is to be moved DUP SLOT \ location of this record DUP RECSIZE + \ location of next record ROT #RECS @ SWAP - \ no. of records to slide over RECSIZE * \ no. of chars to slide over CMOVE> ; \ from lower to higher : TRANSFER ( n - ) SLOT NEW SWAP RECSIZE CMOVE ; : !RECORD ( n - ) DUP SLIDE TRANSFER ; --> \ CLEAR-ENTRY SAVE-RECORD [16] Ham 12:00 11/01/92 : CLEAR-ENTRY NEW RECSIZE BLANK -REVERSE NEW-ENTRY REVERSE ; \ blank entry area and update record count display; \ when executed in a field, inverse video is active, hence \ the -REVERSE and REVERSE : SAVE-RECORD FIND-SPOT !RECORD CLEAR-ENTRY #RECS INCR CHANGE ON #RECS @ MAXRECS = IF 0 24 GOTOXY CLREOL ." File full. Ending new entries. " BELL PRESS DONE ON THEN ; --> \ DELFIRST FIXLAST ENTER [16] Ham 12:00 11/01/92 : DELFIRST NEW 1+ NEW 15 CMOVE BL NEW 15 + C! ; \ slide Last-name over by one character to delete \ character in first position : FIXLAST BEGIN NEW C@ BL = WHILE DELFIRST REPEAT ; \ slide Last-name over until first char is nonblank. : ENTER ( - -1 ) WHICH @ ?DUP IF LASTFIELD = IF FIXLAST SAVE-RECORD WHICH OFF ELSE WHICH INCR THEN ELSE ALL-BLANK? IF DONE ON ELSE WHICH INCR THEN THEN TRUE ; --> \ $GET with variable action [16] Ham 12:00 11/01/92 VARIABLE REGULAR \ routine for regular keys VARIABLE SPECIAL \ routine for special keys VARIABLE LEGAL? \ address of edit for regular keys : $GET ( adr count - ) REVERSE SETUP BEGIN PCKEY IF ( regular key ) REGULAR PERFORM ELSE ( special key ) SPECIAL PERFORM THEN UNTIL -REVERSE ; --> \ REGKEYS [16] Ham 12:00 11/01/92 : REGKEYS ( c - flag ) DUP LEGAL? PERFORM IF INS? @ IF INSERT ELSE OVERTYPE THEN FALSE ELSE CASE BSPKEY OF BACKSPACE FALSE ENDOF ENTERKEY OF ENTER ENDOF ESCKEY OF ESCAPE ENDOF TABKEY OF DOWN ENDOF BELL FALSE SWAP ENDCASE THEN ; --> \ SPECKEYS [16] Ham 12:00 11/01/92 : SPECKEYS ( c - flag ) FALSE SWAP ( put character on top ) CASE HOMEKEY OF HOME ENDOF ENDKEY OF END ENDOF LEFTKEY OF LEFT ENDOF RIGHTKEY OF RIGHT ENDOF DELKEY OF DELETE ENDOF INSKEY OF INS ENDOF LTABKEY OF DROP UP ENDOF UPKEY OF DROP UP ENDOF DOWNKEY OF DROP DOWN ENDOF F1KEY OF HELP ENDOF BELL ENDCASE ; --> \ GETENTRY itself [16] Ham 12:00 11/01/92 : GETENTRY OPEN-FILE GETFILE CLS #RECS @ MAXRECS = IF SCRTITLE 2CR ." No further room in file." PRESS ELSE NEW RECSIZE BLANK NEW-ENTRY WHICH OFF DONE OFF ['] LEGALKEYS LEGAL? ! ['] REGKEYS REGULAR ! ['] SPECKEYS SPECIAL ! BEGIN POSITION-CURSOR ADDR-LENGTH $GET DONE @ UNTIL PUTFILE THEN ; \ NEW-ENTRY's components [17] Ham 12:00 11/01/92 : RECS-REMAINING 27 4 GOTOXY ." New Address Entry Screen" 2CR ." Number of record slots remaining:" MAXRECS #RECS @ - 5 .R ; : SHOW-REC 2CR ." Last Name:" >FIELD 16 TYPE -REVERSE 2CR ." First Name:" >FIELD 16 + 12 TYPE -REVERSE 2CR ." Address 1:" >FIELD 28 + 30 TYPE -REVERSE 2CR ." Address 2:" >FIELD 58 + 30 TYPE -REVERSE 2CR ." City:" >FIELD 88 + 25 TYPE -REVERSE 2CR ." State:" >FIELD 113 + 2 TYPE -REVERSE 2CR ." ZIP:" >FIELD 115 + 10 TYPE -REVERSE 2CR ." Telephone:" >FIELD 125 + 13 TYPE -REVERSE ; : F1MSG 0 24 GOTOXY CLREOL 29 SPACES ." Press F1 for help." ; \ THIS REC-LOC [17] Ham 12:00 11/01/92 0 EQU THIS \ slot number of record on display : REC-LOC 29 4 GOTOXY ." Review/revision Screen" 2CR ." Record " THIS 1+ . ." of " #RECS @ . 2 SPACES ; \ Why the SPACES? Suppose that record 123 of 150 was displayed \ and then record 2 of 150 was displayed. Without the 2 SPACES \ the second message would be: "Record 2 of 15050" because "2" \ takes two fewer spaces than "123" so the second message would \ not completely overwrite the first message. \ Whenever you have a line overwriting an earlier line, you \ must arrange it so that any trailing characters will be \ blanked (or use CLREOL). \ SHOW-ENTRY NEW-ENTRY @RECORD [17] Ham 12:00 11/01/92 : SHOW-ENTRY SCRTITLE REC-LOC SHOW-REC F1MSG ; \ display entry for review/revise : NEW-ENTRY SCRTITLE RECS-REMAINING SHOW-REC F1MSG ; \ display entry for add (new version of NEW-ENTRY) VARIABLE ALTERED \ true = this record modified : @RECORD ( n - ) DUP EQU THIS SLOT NEW RECSIZE CMOVE ALTERED OFF ; \ move record in slot n into NEW \ The above @RECORD includes the phrase to turn off ALTERED. \ SAVE-RECORD CHECK-MAX [17] Ham 12:00 11/01/92 : SAVE-RECORD FIND-SPOT !RECORD CLEAR-ENTRY #RECS INCR CHANGE ON ALTERED OFF ; \ New SAVE-RECORD; see CHECK-MAX : CHECK-MAX #RECS @ MAXRECS = IF 0 24 CLREOL GOTOXY ." File full. Ending new entries. " BELL PRESS DONE ON ELSE -REVERSE NEW-ENTRY REVERSE THEN ; \ CHECK-MAX will follow SAVE-RECORD when you add new records. \ What turns ALTERED on [17] Ham 12:00 11/01/92 \ ALTERED should be turned on by any key that alters the data \ in NEW. These keys include: \ \ all regular alpha keys, whether in INSERT or OVERTYPE mode \ Backspace key (deletes characters) \ Del key \ \ Other keys (including the Enter key) simply move the cursor \ around the displayed record without altering data. \ \ (It's possible, of course, that the keys above might not \ alter the data--for instance, the identical string could be \ be retyped. But one must draw the line somewhere. I drew \ it here.) \ DELREC: a tool word for F5 [17] Ham 12:00 11/01/92 : DELREC ( n - ) \ n = slot from which record is to be deleted DUP SLOT \ location of this record DUP RECSIZE + \ location of next record SWAP \ source=next rec, destination=this rec ROT #RECS @ SWAP - \ no. of records to slide down RECSIZE * \ no. of chars to slide down CMOVE \ from higher to lower CHANGE ON \ work area has been changed #RECS DECR ; \ and there is one fewer record \ DELREC moves garbage over record 200 (when file is full), but \ that's ok since record is considered deleted. (Garbage here \ means data from the 138 bytes following the work area.) It \ seemed simpler to factor DELREC out of F5. \ File extremes GOTONEXT [17] Ham 12:00 11/01/92 \ When PgUp is pressed on the first record in the file, or PgDn \ on the last, you have a choice of "wrapping" (going to the \ record at the other extreme of the file) or beeping. I beep. : GOTONEXT ( n - ) \ replace current rec with rec # on stack -REVERSE \ usually running in REVERSE ALTERED @ \ was record modified? IF THIS DELREC \ if yes, delete old version SAVE-RECORD THEN \ and save new version DUP EQU THIS \ save slot number in THIS @RECORD \ bring in next record SHOW-ENTRY \ and display it WHICH OFF \ with cursor at start REVERSE ; \ back to REVERSE \ PGUP PGDN ENTER2 [17] Ham 12:00 11/01/92 : PGUP ( - flag ) THIS ?DUP IF 1- GOTONEXT TRUE ELSE BELL FALSE THEN ; : LASTSLOT ( - n ) #RECS @ 1- ; \ last slot # is 1 less than # of recs because 1st slot = 0 : PGDN ( -f) THIS DUP LASTSLOT = IF DROP BELL FALSE ELSE 1+ GOTONEXT TRUE THEN ; : ENTER2 ( - -1 ) WHICH @ ?DUP IF LASTFIELD = IF THIS 1+ LASTSLOT MIN GOTONEXT ELSE WHICH INCR THEN ELSE ALL-BLANK? IF DONE ON ELSE WHICH INCR THEN THEN TRUE ; \ New version of ENTER for RREGKEYS: go to next record \ in file (up to end of file). \ F5KEY F10KEY HELP2 F1MSG2 [17] Ham 12:00 11/01/92 63 CONSTANT F5KEY 68 CONSTANT F10KEY : HELP2 ?XY -REVERSE ( called from data field ) CLS SCRTITLE 22 6 GOTOXY ." F5 deletes the current record." 22 8 GOTOXY ." PgUp moves to the previous record." 22 10 GOTOXY ." PgDn moves to the subsequent record." 22 12 GOTOXY ." F10 searches on last name." 25 21 GOTOXY PRESS CLS SHOW-ENTRY GOTOXY REVERSE CURSOR ; : F1MSG2 0 24 GOTOXY CLREOL 23 SPACES ." Press F1 for help, Esc to exit." ; \ DELETE? F5 [17] Ham 12:00 11/01/92 : DELETE? ( - flag ) -REVERSE 0 24 GOTOXY CLREOL 28 SPACES INTENSITY ." Delete this record " Y/N -INTENSITY REVERSE ; : F5 ?XY DELETE? IF 2DROP ( x and y ) ALTERED OFF ( makes no diff; rec gone ) THIS DELREC #RECS @ ( any records left? ) IF THIS LASTSLOT MIN GOTONEXT TRUE ELSE ( no recs left ) -REVERSE 0 24 GOTOXY CLREOL ." File is now empty. Exiting review/revision. " BELL PRESS REVERSE DONE ON TRUE THEN ELSE -REVERSE F1MSG2 REVERSE GOTOXY FALSE THEN ; \ REGKEYS for F10 [17] Ham 12:00 11/01/92 VARIABLE ESCAPED \ true = exited with Esc key : F10REGKEYS ( c - flag ) DUP LEGAL? PERFORM IF INS? @ IF INSERT ELSE OVERTYPE THEN FALSE ELSE CASE BSPKEY OF BACKSPACE FALSE ENDOF ENTERKEY OF TRUE ENDOF ESCKEY OF ESCAPED ON TRUE ENDOF BELL FALSE SWAP ENDCASE THEN ; \ This version is especially for F10's use; the new part \ is the ESCKEY action. \ SPECKEYS for F10 [17] Ham 12:00 11/01/92 : F10SPECKEYS ( c - 0 ) CASE HOMEKEY OF HOME ENDOF LEFTKEY OF LEFT ENDOF RIGHTKEY OF RIGHT ENDOF DELKEY OF DELETE ENDOF INSKEY OF INS ENDOF ENDKEY OF END ENDOF BELL ENDCASE FALSE ; \ This is the same as our original SPECIAL. LEGALKEYS can also \ be the same as the usual LEGALKEYS: no reason to accept a \ blank in first position of search string. : F10SETUP ['] LEGALKEYS LEGAL? ! ['] F10REGKEYS REGULAR ! ['] F10SPECKEYS SPECIAL ! ; \ set up $GET for F10. Will have to preserve and restore \ former contents of the variables. See next screen. \ $SEARCH F10 [17] Ham 12:00 11/01/92 : $SEARCH SPECIAL @ REGULAR @ LEGAL? @ \ save variables F10SETUP NEW 16 $GET \ get search string LEGAL? ! REGULAR ! SPECIAL ! ; \ restore variables : F10 ?XY ALTERED @ IF THIS DELREC SAVE-RECORD THEN NEW RECSIZE BLANK -REVERSE 0 24 GOTOXY CLREOL ." Enter last name for search: " ?XY ( mark spot ) 18 SPACES ." (<Esc> quits without search.)" GOTOXY ( to spot) ESCAPED OFF $SEARCH REVERSE ESCAPED @ IF THIS @RECORD -REVERSE F1MSG2 REVERSE GOTOXY FALSE ELSE 2DROP ( x y from beginning ) FIND-SPOT DUP LASTSLOT > + ( adding flag ) GOTONEXT TRUE THEN ; \ RREGKEYS [17] Ham 12:00 11/01/92 : RREGKEYS ( c - flag ) DUP LEGAL? PERFORM IF ALTERED ON INS? @ IF INSERT ELSE OVERTYPE THEN FALSE ELSE CASE BSPKEY OF ALTERED ON BACKSPACE FALSE ENDOF ENTERKEY OF ENTER2 ENDOF ESCKEY OF ESCAPE ENDOF TABKEY OF DOWN ENDOF BELL FALSE SWAP ENDCASE THEN ; \ RSPECKEYS [17] Ham 12:00 11/01/92 : RSPECKEYS ( c - flag ) FALSE SWAP ( char on top ) CASE HOMEKEY OF HOME ENDOF ENDKEY OF END ENDOF LEFTKEY OF LEFT ENDOF RIGHTKEY OF RIGHT ENDOF DELKEY OF DELETE ALTERED ON ENDOF INSKEY OF INS ENDOF LTABKEY OF DROP UP ENDOF UPKEY OF DROP UP ENDOF DOWNKEY OF DROP DOWN ENDOF F1KEY OF HELP2 ENDOF PGUPKEY OF DROP PGUP ENDOF PGDNKEY OF DROP PGDN ENDOF F5KEY OF DROP F5 ENDOF F10KEY OF DROP F10 ENDOF BELL ENDCASE ; \ REVIEW [17] Ham 12:00 11/01/92 : REVIEW OPEN-FILE GETFILE CLS #RECS @ IF ALTERED OFF DONE OFF REVERSE 0 GOTONEXT -REVERSE ['] LEGALKEYS LEGAL? ! ['] RREGKEYS REGULAR ! ['] RSPECKEYS SPECIAL ! BEGIN POSITION-CURSOR ADDR-LENGTH $GET DONE @ UNTIL PUTFILE NEW RECSIZE BLANK ELSE SCRTITLE 2CR ." No records on file. " PRESS THEN ; \ PROGRESS LINEn? #LINES [17] Ham 12:00 11/01/92 : PROGRESS CONSOLE 22 8 GOTOXY ." Currently printing record " THIS 1+ . ." of " #RECS @ . ; : LINE2? ( - flag ) \ T if line 2 not blank PAD 30 BLANK PAD 30 NEW 28 + 30 STRCMP 0<> ; : LINE3? ( - flag ) \ T if line 3 not blank PAD 30 BLANK PAD 30 NEW 58 + 30 STRCMP 0<> ; : LINE4? ( - flag ) \ T if line 4 not blank PAD 37 BLANK PAD 37 NEW 88 + 37 STRCMP 0<> ; : #LINES ( - n ) \ number of lines required by current entry 2 LINE2? - LINE3? - LINE4? - ; ( computing with flags ) \ NO-ROOM? LINE1 [17] Ham 12:00 11/01/92 : NO-ROOM? ( - flag ) \ true if not enough lines left on page 60 LINE# - #LINES < ; : MARGIN 10 SPACES ; : LINE1 \ print last name, first name phone no. MARGIN NEW 16 -TRAILING TYPE ASCII , EMIT ( last name ) SPACE NEW 16 + 12 -TRAILING TYPE ( first name ) 50 OUT @ - SPACES ( to start of phone field ) NEW 124 + -TRAILING 13 OVER - SPACES ( phone flush rt ) TYPE CR ; \ LINE2 LINE3 LINE4 PRINT-ENTRY [17] Ham 12:00 11/01/92 : LINE2 LINE2? IF MARGIN NEW 28 + 30 -TRAILING TYPE CR THEN ; : LINE3 LINE3? IF MARGIN NEW 58 + 30 -TRAILING TYPE CR THEN ; : LINE4 LINE4? IF MARGIN NEW 88 + 25 -TRAILING TYPE ASCII , EMIT SPACE NEW 113 + 2 -TRAILING TYPE 2 SPACES NEW 115 + 10 -TRAILING TYPE CR THEN ; : PRINT-ENTRY LINE1 LINE2? IF LINE2 THEN LINE3? IF LINE3 THEN LINE4? IF LINE4 THEN CR #LINES LINE# + EQU LINE# ; \ ENTRY PRINT [17] Ham 12:00 11/01/92 : ENTRY NO-ROOM? IF FOOTER TITLE THEN PRINT-ENTRY ; : PRINT CLS SCRTITLE #RECS @ ?DUP IF 1 EQU PAGE# 0 EQU THIS PRINTER TITLE 0 DO I @RECORD PROGRESS ENTRY LOOP FOOTER CONSOLE ELSE 2CR ." No entries in file." BELL PRESS THEN ; \ Example of Ctrl-key combinations [17] Ham 12:00 11/01/92 19 CONSTANT ^S 4 CONSTANT ^D 5 CONSTANT ^E 7 CONSTANT ^G 24 CONSTANT ^X 8 CONSTANT ^H \ Similar constants can be defined for Ctrl-key combinations \ of your choice. Use KEY or PCKEY to determine the proper \ values. \ Example of Ctrl-key combinations [17] Ham 12:00 11/01/92 : WSREGKEYS ( c - flag ) DUP LEGAL? PERFORM IF ALTERED ON INS? @ IF INSERT ELSE OVERTYPE THEN FALSE ELSE FALSE SWAP ( flag under character ) CASE BSPKEY OF BACKSPACE ENDOF ENTERKEY OF ENTER ENDOF ESCKEY OF ESCAPE ENDOF TABKEY OF DOWN ENDOF ^S OF LEFT ENDOF ^D OF RIGHT ENDOF ^E OF UP ENDOF ^G OF DELETE ENDOF ^X OF DOWN ENDOF ^H OF BACKSPACE ENDOF BELL FALSE SWAP ENDCASE THEN ; \ The above illustrates how additional functionality can be \ added to the keyboard input routine. \ Complete page number [17] Ham 12:00 11/01/92 VARIABLE #ofPAGES \ no. of pages : COUNTPAGES 1 #ofPAGES ! 9 ( starting line # each page ) #RECS 0 DO I @RECORD #LINES + 60 > IF #ofPAGES INCR DROP 9 #LINES + THEN LOOP DROP ; : .PAGE ." Page" PAGE# 3 .R ." of " #ofPAGES @ . ; \ Put COUNTPAGES at the very beginning of the print routine-- \ COUNTPAGES is a part of housekeeping. Because .PAGE now will \ take more spaces, you need to print it more to the left. \ I didn't test this word--I left that for you. Be sure that it\ doesn't get off when the last entry is exactly at the bottom \ of the page. \ Sorts [18] Ham 12:00 11/01/92 : SORT #ELTS @ 29524 U> \ check for limit IF CR #ELTS @ U. ." items exceeds sort limit of 29524." ELSE INTERVAL BEGIN 3 / ?DUP ( down to next gap size ) WHILE ( gap size > 0 ) DOEACHPART REPEAT ( for next smaller gap size ) THEN ; : COMPARE ( i1 i2 - f ) SORTPLACE + C@ SWAP SORTPLACE + C@ > ; \ This does a descending sort--only change is from < to >. \ COMPARE and SWAP'EM for ADDRESS.SCR: left as an exercise \ for the reader. \ 2NIP 2TUCK S>D D0= [19] Ham 12:00 11/01/92 : 2NIP ( d1 d2 - d2 ) 2SWAP 2DROP ; : 2TUCK ( d1 d2 - d2 d1 d2 ) 2SWAP 2OVER ; : S>D ( s - d ) DUP 0< ; : D0= ( d - flag ) OR ; \ In the above definition of D0=, the two cells of the double \ are combined with OR so that the resulting single has no bits \ on only if no bits are on in either cell of the double: \ that is, only if the double is 0. To make this D0= leave \ a bona fide flag (-1 or 0), just add 0<> after OR. \ DU> D0> D<= D>= D0<> [19] Ham 12:00 11/01/92 : DU> ( d1 d2 - flag ) 2SWAP DU< ; : D0> ( d1 - flag ) 0. D> ; : D<= ( d1 d2 - flag ) D> NOT ; : D>= ( d1 d2 - flag ) D< NOT ; : D0<> ( d1 - flag ) D0= NOT ; \ If you use a double-precision comparison to compare a double \ and single, the stack remains empty (as you observed in our \ experiments). \ To compare a double and a single and get the right result, \ first convert the single to a double, then use a double- \ precision comparison command. \ D>S UD>S [19] Ham 12:00 11/01/92 : D>S ( d - s T | d F ) 2DUP 32768. D< 0 2OVER -32769. D> NIP ( to drop 0 used for 2OVER ) AND DUP IF NIP THEN ; \ The above word rejects positive doubles that would convert \ to negative singles--e.g., 65535. is rejected. : UD>S ( ud - u T | ud F ) 2DUP 65536. D< 0 2OVER 0. D> NIP AND DUP IF NIP THEN ; \ Both D>S and UD>S needed? [19] Ham 12:00 11/01/92 \ It would be possible to have a single double-to-single word \ that accepted numbers greater than -32769. and less than \ 65536. with the understanding that distinct doubles could \ be converted into the same single. For instance, the \ >signed< double 65535. would be converted to the >signed< \ single -1 (or the unsigned single 65535). So for signed \ doubles, this "broad-range" conversion word would be \ dangerous: the single -1 could be the result of the double \ -1. or the double 65535. and that seems undesirable. \ DNEGAT DABS DMAX DMIN [19] Ham 12:00 11/01/92 : DNEGATE ( d - -d ) 0. 2SWAP D- ; : DABS ( d - |d| ) 2DUP D0< IF DNEGATE THEN ; : DMAX ( d1 d2 - max ) 2OVER 2OVER D< IF 2SWAP THEN 2DROP ; : DMIN ( d1 d2 - min ) 2OVER 2OVER D> IF 2SWAP THEN 2DROP ; \ U/ UMOD PLACES [20] Ham 12:00 11/01/92 : U/ ( u1 u2 - uquot ) 0 SWAP UM/MOD NIP ; : UMOD ( u1 u2 - urem ) 0 SWAP UM/MOD DROP ; \ 0 SWAP converts the single u1 to a double, for UM/MOD \ The version of COUNTDIGITS that uses a BEGIN WHILE REPEAT \ loop with NINES doesn't work for input of 10 digits. \ The problem is that NINES cannot include the case of ten \ 9's (9999999999.) since the double-precision numbers end \ at 4294967296. VARIABLE #DIGITS 0 EQU DECIMALS : PLACES ( n - ) EQU DECIMALS ; \ .# with + as well as - [20] Ham 12:00 11/01/92 : COUNTDIGITS ( d - ) DABS 1 #DIGITS ! BEGIN 10 D/ 2DUP D0> WHILE #DIGITS INCR REPEAT 2DROP ; : #COMMAS ( - # ) #DIGITS @ DECIMALS - 3 /MOD SWAP 0= + 0 MAX ; : +SIGN ( n - ) DUP 0< IF SIGN ELSE IF ASCII + HOLD THEN THEN ; : .# ( d - adr cnt ) 2DUP ( next, save sign for +SIGN ) D0< IF -1 ELSE 2DUP D0= IF 0 ELSE 1 THEN THEN >R DABS 2DUP COUNTDIGITS <# DECIMALS ?DUP IF 0 DO # LOOP ASCII . HOLD THEN #COMMAS 0 ?DO # # # ASCII , HOLD LOOP #S R> +SIGN #> ; \ Better way to count digits [20] Ham 12:00 11/01/92 \ COUNTDIGITS shows two common errors: (1) writing a \ routine that is too complex by (2) reinventing a Forth \ command. Forth provides a command that returns the count \ of digits in a double-precision number. Look at this \ definition: : COUNTDIGITS ( d - ) <# #S #> \ leaves: adr count #DIGITS ! \ save count DROP ; \ drop address \ Because of Forth's natural modularity, you can revise \ this single definition with no effect on the surrounding \ code. Time this definition to see how its speed compares. \ %OF % [21] Ham 12:00 11/01/92 : .TENTHS ( n - ) \ assume n is to 100ths, print to 10ths 5 + 10 / 10 /MOD 0 .R ASCII . EMIT . ; : %OF ( n1 n2 - n3 ) \ n3 is n2% of n1, to tenths 100 * 100 */ .TENTHS ; \ But see comment: better is * \ If n2 is a percentage, it is n2/100; so your first thought is \ to define %OF as 100 */ But we want the answer to 10ths, so \ we must multiply by 100 to get to 100ths and then round. This \ leads to multiplying by 100 and dividing by 100. Better: : %of ( n1 n2 - n3 ) ( n3 is n2% of n1, to tenths ) * .TENTHS ; : % ( n1 n2 - n3 ) \ n3 is the % that n1 is of n2 10000 SWAP */ .TENTHS ; \ DAY-IN, DAY-OUT [22] Ham 12:00 11/01/92 \ Do DAY-OUT first: much simpler since you can work completely \ internally to the program: no interaction with user. VARIABLE MO/DA \ both in same variable since each < 255 CREATE MONTHS ," JanFebMarAprMayJunJulAugSepOctNovDec" \ Using lower case improves readability and also avoids hex \ values FEB and DEC. Because month number is not zero-based, \ we must subtract 1 from month number before looking up month \ name, or begin the name array with 3 blanks (to occupy the \ slot for month "0", putting month 1 in the right place). The \ word 1- takes two bytes; 3 blanks would take 3 bytes. So we \ subtract 1 instead of using 3 blanks. (16-bit Forth) \ DAY-OUT [22] Ham 12:00 11/01/92 : .DAY ( n - ) DUP 0 .R DUP 3 > OVER 21 < AND IF DROP ." th" ELSE 10 MOD CASE 1 OF ." st" ENDOF 2 OF ." nd" ENDOF 3 OF ." rd" ENDOF ." th" ENDCASE THEN ; \ Accommodate peculiarities of the English language: \ "11th" not "11st", "12th" not "12nd", and "13th" not "13rd". : DAY-OUT MO/DA C@ 1- 3 * MONTHS + 3 TYPE SPACE \ display month MO/DA 1+ C@ .DAY ; \ and day \ Often a good strategy is to do easy part first, to get some \ quick (and positive) experience with the problem. \ DAY-IN: CAP FIX LASTDAY [22] Ham 12:00 11/01/92 : CAP ( c - C ) DUP ASCII ` > OVER ASCII { < AND IF BL - THEN ; : FIX ( n - n) CAP CASE ASCII L OF ASCII 1 ENDOF \ L -> 1 ASCII O OF ASCII 0 ENDOF \ O -> 0 ASCII / OF 13 ( cr) ENDOF \ / -> cr ASCII - OF 13 ( cr) ENDOF \ - -> cr DUP ENDCASE ; \ Jan Feb Mar Apr May Jun CREATE LASTDAY 0 C, 31 C, 29 C, 31 C, 30 C, 31 C, 30 C, 31 C, 31 C, 30 C, 31 C, 30 C, 31 C, \ Jul Aug Sep Oct Nov Dec \ If year were available, could determine whether last day for \ Feb is 29 or only 28; without year, must use default of 29. \ DAY-IN: #? "DISPLAY TAB TOP ASCII># [22] Ham 12:00 11/01/92 : #? ( n - f ) DUP ASCII 0 >= SWAP ASCII 9 <= AND ; VARIABLE MONTH? \ true = month, false = day : "DISPLAY 10 5 GOTOXY ." Month: Day:" ; : TAB MONTH? @ IF 18 ELSE 30 THEN 5 GOTOXY ; : TOP ( - n ) MONTH? @ IF 12 ELSE MO/DA C@ LASTDAY + C@ THEN ; : ASCII># ( c - n ) ASCII 0 - ; \ convert ASCII to digit : BELL 440 25 BEEP ; \ DAY-IN: explanation [22] Ham 12:00 11/01/92 \ On next screen is word that appends new digit to existing \ number--for example, if the existing number is 1 and the user \ types 2, the result is 12. This routine observes limits: if \ the existing number is 9 and the user types 2, the result is \ 2, not 92 (out of range for both month and day). \ The word does not allow user to create an entry of 0--for \ example, if entry is 10 (or 9), user cannot enter 0. Also, if \ entry is 11, entry of 1 produces 1, not 11 again. (The user \ clearly did not want 11, so why force it on him or her?) \ Same for 22 and entry of 2: result is 2, not another 22. \ FIX converts / and - to Enter because when entering dates, a \ user will often unconsciously use / or - between month & day. \ DAY-IN: NEW# [22] Ham 12:00 11/01/92 : NEW# ( m/d # - m/d' ) \ append new digit to month or day OVER 10 MOD OVER D0= \ is zero going to result? IF DROP BELL \ if so, reject this key ELSE 2DUP 11 1 D= >R \ is 1 coming in on 11 2DUP 22 2 D= R> OR \ or 2 on 22? IF NIP \ if so, leave just 1 (or 2) ELSE OVER >R >R \ save copy of the old & the new 10 MOD 10 * R@ + \ append new digit DUP TOP > \ is result too big? IF DROP R> \ if so, bring back new digit ?DUP IF R> DROP \ drop old if new <>0 ELSE R> BELL THEN \ keep old if new = 0 ELSE R> R> 2DROP THEN THEN THEN ; \ else keep \ result \ DAY-IN: 1/1 ENTER LEFT DONE M/D [22] Ham 12:00 11/01/92 257 CONSTANT 1/1 \ value to initialize date to default 1/1 13 CONSTANT ENTER \ value of Enter key 75 CONSTANT LEFT \ value of Left-arrow key VARIABLE DONE \ 0=continue, -1=done, 1=re-do month : M/D ( - adr ) MO/DA MONTH? @ NOT NEGATE + ; \ M/D provides correct address for month byte or day byte. \ DAY-IN: GET# [22] Ham 12:00 11/01/92 : GET# DONE OFF REVERSE M/D C@ \ get current value on stack BEGIN TAB DUP 2 .R PCKEY \ display it (inverse video) IF FIX DUP #? \ is regular key a number? IF ASCII># NEW# \ if so, do number work ELSE ENTER = \ if not, is it Enter key? IF DONE ON \ if so, we're done ELSE BELL THEN THEN \ if not, it's error ELSE LEFT = MONTH? @ NOT AND \ go back to month? IF 1 DONE ! \ set DONE nonzero but not -1 ELSE BELL THEN THEN \ otherwise, error DONE @ UNTIL \ do until DONE is nonzero -REVERSE TAB DUP 2 .R \ display final value regular M/D C! ; \ and store it \ DAY-IN [22] Ham 12:00 11/01/92 : DAY-IN 1/1 MO/DA ! "DISPLAY \ default is Jan 1st MONTH? OFF M/D C@ TAB 2 .R \ display day value BEGIN MONTH? ON GET# \ get month MONTH? OFF GET# \ get day DONE @ TRUE = UNTIL ; \ until truly done \ Additional challenges: \ Add a backspace function. \ Add an Esc key function. \ (You decide what these two functions should do.) \ Take out the specific location so that the word works at \ wherever the cursor currently finds itself. \ AIM S>B MASK ~BIT READOUT NUMBEROUT [23] Ham 12:00 11/01/92 : AIM ( # adr - bit# adr' ) SWAP 8 /MOD ROT + ; : S>B ( ? - f ) 0<> ; \ force to a Boolean flag: -1 or 0 : MASK ( bit# - bitmask ) BITS + C@ ; : ~BIT ( bit# adr - ) AIM 2DUP @BIT IF -BIT ELSE +BIT THEN ; : READOUT 128 0 DO I TEST @BIT IF I EMIT THEN LOOP SPACE ; : NUMBEROUT 16 0 DO TEST I + @ . WSIZE +LOOP ; \ LEGAL OK-CHAR? [23] Ham 12:00 11/01/92 CREATE LEGAL WSIZE 4 = ( check for 32-bit Forth) .IF 0 , 67052538 , -2013265921 , 671088641 , .ELSE 0 , 0 , 9210 , 1023 , -1 , -30721 , 1 , 10240 , .THEN : OK-CHAR? ( ASCII-char - flag ) LEGAL @BIT ; \ T = legal \ Chapter [24] : FILESPACE ( - d ) 48 >< regAX ! 33 INT86 regAX C@ 2 < IF -1. ( error: DOS version before 2.0 ) ELSE <remainder of definition as in book> THEN ; \ Chapter [25] >>FILE because each entry must be appended: : OUTPUT PRT? @ IF PRINTER ELSE >>FILE ADDRESS.PRN THEN ; \ MO/DA/YR .HR-MIN .AM-PM [25] Ham 12:00 11/01/92 : .0N ( n -) DUP 10 < IF ASCII 0 EMIT THEN 0 .R ; \ 2 versions: .0N ( n -) 0 <# # # #> TYPE ; \ which is faster? smaller? : MO/DA/YR @DATE 256 /MOD .0N ASCII / EMIT .0N ASCII / EMIT 100 MOD 0 .R ; \ no trailing space : .HR-MIN @TIME DROP 256 /MOD 2 .R ASCII : EMIT .0N ; : .AM-PM @TIME DROP 256 /MOD 2DUP 0 12 D= IF 2DROP ." 12:00n " ELSE 2DUP 0 0 D= IF 2DROP ." 12:00m " ELSE DUP 11 > -ROT 12 MOD ?DUP 0= IF 12 THEN 2 .R ASCII : EMIT .0N IF ASCII p ELSE ASCII a THEN EMIT ASCII m EMIT THEN THEN ; \ 3DUP =&=&= [25] Ham 12:00 11/01/92 : 3DUP ( n1 n2 n3 - n1 n2 n3 n1 n2 n3 ) DUP >R >R 2DUP R> -ROT R> ; : =&=&= ( n1 n2 n3 n4 n5 n6 - flag ) >R ROT >R D= R> R> = AND ; \ =&=&= leaves "true" flag only if n1=n4 and n2=n5 and n3=n6 \ Often when programming you learn more about some subjects than\ you ever expected to know. For example, in working on a \ calendar I wanted to show holidays. Most holidays were easy \ enough to compute--first Monday in September, last Monday in \ May, nearest weekday to July 4--but the Easter-related \ holidays were a challenge. The next three screens show the \ result of my research. \ Easter algorithm [25] Ham 12:00 11/01/92 \ \ Easter falls on the first Sunday >following< the arbitrary \ Paschal Full Moon, which does not necessarily coincide with a \ real or astronomical full moon. The Paschal Full Moon is \ determine by taking the year MOD 19 and using this table: \ \ 0. Apr 14 4. Mar 31 8. Apr 16 12. Apr 2 16. Apr 17 \ 1. Apr 3 5. Apr 18 9. Apr 5 13. Mar 22 17. Apr 7 \ 2. Mar 23 6. Apr 8 10. Mar 25 14. Apr 10 18. Mar 27 \ 3. Apr 11 7. Mar 28 11. Apr 13 15. Mar 30 \ \ Example: 2000 19 MOD gives 5: Apr 18. That date (in 2000) \ is a Tuesday, so Easter Sunday in the year 2000 is Apr 23. \ \ When the Paschal Full Moon is Sunday, Easter is the NEXT Sun. \ Easter algorithm [25] Ham 12:00 11/01/92 \ The earliest Easter Sunday possible is Mar 23; the latest is \ Apr 25. Ash Wednesday is 46 days before Easter Sunday. \ The best approach was to compute the Sunday dates by year and \ build a table of the dates. The table can then be used in the\ program. The table in the next screen Easter Sundays for the \ years 1901 through 2076. Each date occupies one byte. March \ dates at first used a 0 prefix and April dates a 1 prefix: \ 028 = March 28; 115 = April 15. The offset into the table is \ obtained by subtracting 1901 from the year of interest. This \ approach exposed March dates to problems with INCLUDE, which \ forces bytes to a minimum valule of 32 (the constant BL). \ The table was then modified so that March dates were \ incremented by 32, which secured them from alteration by \ INCLUDE. The retrieval routine then decrements the dates. \ Easter table 1901-2076 [25] Ham 12:00 11/01/92 CREATE ETABLE \ INCLUDE-proof table of Easter Sundays 1901-2076," k>pg{s?wo;tk7ph{l?xh;texphul?xi;teyp<um8qi}meyj<um9qivneyj=ufzr=vn:rj=ofzr>vn:sjwogzk>wg:s?wogtk>ph{s?xo;tl7ph|l?xi;teyphum?xi<teyq<um9qi}neyj=um9rivnfyj=vfzr>vn:sj=ogzr>wn:skw" : @EASTER ( yr - da mon | 0 ) DUP 1901 < OVER 2076 > OR IF ." The year " U. ." is out of range for this table. " 0 ELSE 1901 - ETABLE + C@ DUP 100 > IF 100 - 4 ( Apr ) ELSE BL - 3 ( Mar ) THEN THEN ; : .EASTER ( yr - ) DUP @EASTER ?DUP IF 4 = IF ." April " ELSE ." March " THEN 0 .R ." , " . ELSE DROP ( yr ) THEN ; \ SPELL [26] Ham 12:00 11/01/92 : SPELL BL WORD FIND \ look up the word IF >BODY \ if found, go to parameter field BEGIN \ start loop DUP @ \ save copy of pfa & retrieve adr DUP \ save a copy of the address ['] unnest <> \ "unnest" means the end of the defn WHILE \ while not at end >NAME .NAME SPACE \ display the name WSIZE + \ move to next pfa KEY DROP \ pause REPEAT \ go back 2DROP \ when done, drop the 2 addresses ELSE DROP \ if not found, drop address ." Not found " \ and display message THEN ; \ FACTORIAL GCD FACTORIAL2 [26] Ham 12:00 11/01/92 : OOPS CR ." Too big: 8 is the maximum for this definition. " ; : FACTORIAL ( n - n! ) DUP 8 U> IF OOPS ELSE DUP 1 > IF DUP 1- RECURSE * THEN THEN ; : GCD ( x y - gcd ) BEGIN ?DUP WHILE TUCK UMOD REPEAT ; \ The nonrecursive definitions are faster; test with !TIMER \ and .TIMER. : FACTORIAL2 ( n - n! ) DUP 8 U> IF OOPS ELSE DUP BEGIN DUP 1 > WHILE 1- TUCK * SWAP REPEAT DROP ( final 1 ) THEN ; \ BITS>BYTES [27] Ham 12:00 11/01/92 : BITS>BYTES ( #bits - #bytes ) 8 /MOD SWAP IF 1+ THEN ; \ The above will convert a number of bits into the number of \ bytes required to hold that many bits (possibly with some \ bits left over). For example 20 bits requires 3 bytes. \ Problem in V: [27] Ham 12:00 11/01/92 \ The definition of V: in the book was written using 16-bit \ UR/FORTH. Then, in using UR/FORTH 386, the 32-bit version, \ a problem was found. In 386 UR/FORTH, when DOES> executes, \ it slides over the CREATE clause to get more room; this is \ the result of an early approach to dealing with the code and \ data in the same segment. It causes a problem only for words \ using HERE to lay down data in literal addresses while using \ CREATE. Although UR/FORTH 386 could change its method, this \ would mean that developers who built applications based on \ how UR/FORTH worked in the first release could find serious \ problems suddenly appear when the same applications are \ compiled with a later version of UR/FORTH. This is to be \ avoided, and the next screen tells how. \ Solutions [27] Ham 12:00 11/01/92 \ The words .IF .ELSE and .THEN apply perfectly to situations \ in which differences between versions of UR/FORTH go beyond \ what can be accommodated with WSIZE. For example, to use \ different definitions in 16-bit and 32-bit versions: \ WSIZE 2 = .IF <16-bit version> .ELSE <32-bit version> .THEN \ Another approach is to take a hard look at the definition \ itself. Perhaps its variant behavior is an indication that \ the initial approach was too closely tied to the internals of \ the compiler operation. Maybe it is possible to rewrite the \ definition so that it will behave in both versions. The \ latter approach is taken here. \ Solutions, cont'd [27] Ham 12:00 11/01/92 \ The problem in V: stems from the phrase HERE -1 , CREATE \ Even as I wrote it, I was uncomfortable with starting a \ CREATE DOES> definition with something other than CREATE, but \ I didn't pay enough attention to the discomfort. I was \ hypnotized by the notion that the addresses I would start \ should start immediately after CREATE, but of course that \ isn't necessary at all. I could equally well have put first \ the storage location for the maximum option number and had \ the addresses follow that. And that approach in fact \ simplifies the definitions (another indication that it's a \ better approach). On the next three screens you see the new \ V: and VSPILL. These work with both the 16-bit and 32-bit \ UR/FORTH. Compare these to the definitions in the book, \ which work only with the 16-bit UR/FORTH. \ Revised V: for vector arrays [27] Ham 12:00 11/01/92 : V: CREATE HERE -1 , ( location for option number ) BEGIN BL WORD DUP COUNT " ;" COUNT STRCMP IF FIND IF , ( save adr ) DUP INCR ( & incr opt # ) ELSE ." not found" ABORT THEN FALSE ELSE 2DROP ( adr & HERE ) TRUE THEN UNTIL DOES> ( n <adr> - ) DEPTH 2 < IF ." Option no. missing!" ABORT THEN SWAP 0 MAX OVER @ ( maximum option number) MIN 1+ ( to get past opt # location ) WSIZE * + PERFORM ; \ The option number of the last option, saved at CREATE time, \ is used to clip input at DOES> time. \ Example of V: in action [27] Ham 12:00 11/01/92 : OPT0 ." First option " CR ; \ options : OPT1 ." Second option " CR ; : OPT2 ." Third option " CR ; V: TED OPT0 OPT1 OPT2 ; \ Create new execution array 0 TED \ first option 2 TED \ third option 65 TED \ also third option because of clipping TED \ aborts because no option number offered \ Revised inspection word for V: [27] Ham 12:00 11/01/92 : VSPILL BL WORD DUP CR COUNT TYPE FIND IF ." contains: " >BODY DUP @ 1+ 0 DO WSIZE + DUP @ >NAME .NAME SPACE LOOP DROP ELSE ." not found. " THEN ; \ When used with words defined by the V: in the previous screen,\ VSPILL will display their contents. From previous screen: \ VSPILL TED will display: \ TED contains: OPT1 OPT2 OPT3 ok \ VSPILL FXJLQ will display: \ FXJLQ not found. ok \ Defining word for CHARACTER objects [27] Ham 12:00 11/01/92 0 EQU ACTION \ code for action : MEANS ( n - ; name ) CREATE C, DOES> C@ EQU ACTION ; 1 MEANS COLLECT 2 MEANS REVIEW 3 MEANS DISPLAY : .N ( pfa - ) BODY> >NAME .NAME ; \ print name from pfa \ Printing the word name will not work if program is created \ with TURNKEY, because TURNKEY discards the headers, which \ include the names. VARIABLE LABEL \ "true" means display label --> \ Strings enhancement [27] Ham 12:00 11/01/92 : CHARACTER ( n - ) \ defining word for string words CREATE DUP C, HERE SWAP DUP ALLOT BLANK \ create header, store char count, initialize area DOES> ( <adr> - ) DUP COUNT ACTION CASE 1 OF ( collect ) ROT LABEL @ IF ." Enter " .N ." : " ELSE DROP THEN 2DUP BLANK $GETC ENDOF 2 OF ( review ) ROT LABEL @ IF ." Revise " .N ." : " ELSE DROP THEN ?XY 2OVER TYPE GOTOXY $GETC ENDOF 3 OF ( display ) ROT LABEL @ IF .N ." : " ELSE DROP THEN -TRAILING TYPE ENDOF CR ." Invalid action code = " . ABORT ENDCASE ; --> \ Examples [27] Ham 12:00 11/01/92 20 CHARACTER name 30 CHARACTER address LABEL ON \ try it a second time, changing ON to OFF COLLECT CR CR name CR address REVIEW CR CR name CR address DISPLAY CR CR name CR address CR \ New version of CHARACTER [27] Ham 12:00 11/01/92 4 MEANS $ADDRESS \ just put string address on stack : CHARACTER ( n - ) \ defining word for string words CREATE DUP C, HERE SWAP DUP ALLOT BLANK \ create header, store char count, initialize area DOES> ( <adr> - ) DUP COUNT ACTION CASE 1 OF ( collect ) 2DUP BLANK $GETC ENDOF 2 OF ( review ) ?XY 2OVER TYPE GOTOXY $GETC ENDOF 3 OF ( display ) -TRAILING TYPE ENDOF 4 OF ( address ) DROP 1- ENDOF CR ." Invalid action code = " . ABORT ENDCASE ; \ MESSAGE (self-displaying messages) [27] Ham 12:00 11/01/92 0 CONSTANT NORMAL \ Can enter message with any of 1 CONSTANT BLINKING \ four attributes; use of constant 2 CONSTANT BRIGHT \ is appropriate since each message 3 CONSTANT UNDERSCORE \ will have its own display mode 4 CONSTANT INVERSE : .$ ( adr - ) COUNT TYPE ; \ display string : MESSAGE ( n - ; <name> ) CREATE C, ,C" DOES> COUNT CASE NORMAL OF .$ ENDOF BLINKING OF BLINK .$ -BLINK ENDOF BRIGHT OF INTENSITY .$ -INTENSITY ENDOF UNDERSCORE OF UNDERLINE .$ -UNDERLINE ENDOF INVERSE OF REVERSE .$ -REVERSE ENDOF ENDCASE ; \ Sample messages [27] Ham 12:00 11/01/92 BLINKING MESSAGE FRED Look out!!" INVERSE MESSAGE SAM Here is inverse video" BRIGHT MESSAGE PAT Welcome to Forth" NORMAL MESSAGE TED Press F1 for help" CR CR FRED CR CR SAM CR CR PAT CR CR TED CR CR \ Floating point F>R and FR> [28] Ham 12:00 11/01/92 \ : F>R ( f - ) FPSIZE 0 DO >R LOOP ; \ : FR> ( - f ) FPSIZE 0 DO R> LOOP ; \ The above two definitions are a very BAD idea. Remember, \ the return stack is where Forth stores information for itself,\ including: 1) the limits for DO LOOPs, and 2) the address of \ where it is to return. In the above example, the floating \ point number would be placed above the return address for \ the definition, and also above the DO LOOP limits, which are \ expunged from the return stack when the loop is complete. \ The above definitions are a quick ticket to program oblivion. \ Area of circle [28] Ham 12:00 11/01/92 SFP \ load software floating point : AREA1 ( f - f') FDUP F* FPI F* ; \ area with multiplication : AREA2 ( f - f') 2E F** FPI F* ; \ area with exponentiation : AREA3 ( d - d') DUP M* 1000 D* 355 D* 113 D/ ; \ with doubles : TEST1 !TIMER 2000 0 DO 4E AREA1 FDROP LOOP .TIMER ; : TEST2 !TIMER 2000 0 DO 4E AREA2 FDROP LOOP .TIMER ; : TEST3 !TIMER 2000 0 DO 4 AREA3 2DROP LOOP .TIMER ; : TEST4 !TIMER 2000 0 DO 3E AREA2 FDROP LOOP .TIMER ; : D.3 ( d - ) <# # # # ASCII . HOLD #S #> TYPE SPACE ; CR CR 4E AREA1 .( Using FDUP ) F. 4 SPACES TEST1 CR CR 4E AREA2 .( Using F** ) F. 4 SPACES TEST2 CR CR 4 AREA3 .( Using doubles ) D.3 9 SPACES TEST3 CR CR .( Using F** and 3E [long wait] ) TEST4 \ Compound interest [28] Ham 12:00 11/01/92 SFP FVARIABLE INTEREST \ to stash value: no F>R or FR> : FVALUE ( n1 f1 n2 - ) \ show dollars and cents at end \ n1 = # months; f1 = annual %age rate; n2 = # of $ at start 2 PLACES >R \ set places, stash amount (dollars) S>F 1200E F/ INTEREST F! \ get & save MONTHLY interest R> SWAP >R \ retrieve amount, stash no. of month S>F \ float the amount INTEREST F@ FSWAP \ retrieve interest, arrange stack R> 0 DO \ loop once for each month FOVER FOVER F* F+ LOOP \ compute and accumulate interest FSWAP FDROP \ drop interest .005E F+ \ round up to nearest cent ASCII $ EMIT F. ; \ show dollars & cents \ Compound interest [28] Ham 12:00 11/01/92 SFP \ load software floating point FVARIABLE INTEREST \ to stash value: no F>R or FR> : FVALUE ( n1 f1 n2 - ) \ show dollars and cents at end \ n1 = # months; f1 = annual %age rate; n2 = # of $ at start 2 PLACES >R \ set places, stash amount (dollars) S>F 1200E F/ 1E F+ \ monthly interest increment INTEREST F! \ save the interest S>F \ float the number of months INTEREST F@ FSWAP F** \ compute the power R> S>F F* \ retrieve amount, float, & multiply .005E F+ \ round up to nearest cent ASCII $ EMIT F. ; \ show dollars & cents \ Time the two approaches [28] Ham 12:00 11/01/92 FVARIABLE INTEREST : F.$ ( f - ) 2 PLACES .005E F+ ASCII $ EMIT F. ; : FVALUE1 ( n1 f1 n2 - ) \ n1 # months; f1 yr rate; n2 # $ >R 1200E F/ INTEREST F! R> SWAP >R S>F INTEREST F@ FSWAP R> 0 DO FOVER FOVER F* F+ LOOP FSWAP FDROP ; : FVALUE2 ( n1 f1 n2 - ) >R 1200E F/ 1E F+ INTEREST F! S>F INTEREST F@ FSWAP F** R> S>F F* ; : DO1 !TIMER 500 0 DO 12 8.5E 1000 FVALUE1 FDROP LOOP .TIMER ; : DO2 !TIMER 500 0 DO 12 8.5E 1000 FVALUE2 FDROP LOOP .TIMER ; CR CR .( Loop: ) DO1 CR CR .( Exponent: ) DO2 \ Then try it again after changing 12 months to 90. \ Floating point functions [28] Ham 12:00 11/01/92 FVARIABLE DISTANCE 50E DISTANCE F! \ initialize distance: 50 feet 2 PLACES : .HT ( f - ) ." Object is " F. ." feet high." ; : ANGLE ( f - ) FTAN DISTANCE F@ F* 5.005E F+ .HT ; : f** ( f1 f2 -- f1**f2 ) FSWAP FLOG F* FALOG ; \ COORDINATES CLINE (general) [29] Ham 12:00 11/01/92 : COORDINATES 0 0 639 0 CLINE 0 0 0 199 CLINE ; : CLINE ( x1 y1 x2 y2 ) ?MODE DUP 15 = OVER 16 = OR IF ( res is 640X350) DROP 349 ELSE DUP 17 = SWAP 18 = OR IF ( 640X480) DROP 479 ELSE DROP 199 THEN THEN DUP >R SWAP - ROT R> SWAP - -ROT LINE ; \ CLINE assumes that you are in graphics mode and does not \ check for the character modes. You the programmer are \ responsible for using it correctly. This version of CLINE \ may not work with non-IBM displays. \ !CPEL @CPEL [29] Ham 12:00 11/01/92 : CPEL ( x y1 - x y2 ) ?MODE DUP 15 = OVER 16 = OR IF ( res is 640X350) DROP 349 ELSE DUP 17 = SWAP 18 = OR IF ( it's 640X480 ) DROP 479 ELSE DROP 199 THEN THEN SWAP - ; : !CPEL ( x y - ) CPEL !PEL ; : @CPEL ( x y - ) CPEL @PEL ;
